Add private to some symbols in the Sort module

These symbols were marked with the "no doc" pragma and seemed to be module
internal, so I'm marking them as private.  When chpldoc is able to recognize
private symbols, the pragmas can be removed.

/*
 * Copyright 2004-2015 Cray Inc.
 * Other additional copyright holders may be indicated within.
 *
 * The entirety of this work is licensed under the Apache License,
 * Version 2.0 (the "License"); you may not use this file except
 * in compliance with the License.
 *
 * You may obtain a copy of the License at
 *
 *     http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 */

/*
   The `Sort` module is designed to support standard sorting
   routines.  The current interface is minimal and should be expected to
   grow and evolve over time. Each of the following functions accepts an
   optional boolean argument, `reverse`, which is `false` by
   default. If `true`, then the sort function will order in reverse.

 */
module Sort {

pragma "no doc"
private inline proc chpl_sort_cmp(a, b, param reverse=false, param eq=false) {
  if eq {
    if reverse then return a >= b;
    else return a <= b;
  } else {
    if reverse then return a > b;
    else return a < b;
  }
}

/*
   Sort the 1D array `Data` in-place using a sequential bubble sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc BubbleSort(Data: [?Dom] ?elType, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.dim(1).low;
  const hi = Dom.dim(1).high;
  var swapped = true;

  while (swapped) {
    swapped = false;
    for i in lo..hi-1 {
      if !chpl_sort_cmp(Data(i), Data(i+1), reverse, true) {
        Data(i) <=> Data(i+1);
        swapped = true;
      }
    }
  }

  if (doublecheck) then VerifySort(Data, "BubbleSort", reverse);
}

/*
   Sort the 1D array `Data` in-place using a sequential heap sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] elType
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc HeapSort(Data: [?Dom] ?elType, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.dim(1).low;
  const hi = Dom.dim(1).high;
  const len = Dom.dim(1).size;

  // heapify
  var start = (len - 2) / 2 + lo;
  while (start >= lo) {
    SiftDown(start, hi);
    start = start - 1;
  }

  // sort, moving max element to end and re-heapifying the rest
  var end = hi;
  while (end > lo) {
    Data(end) <=> Data(lo);
    end = end - 1;
    SiftDown(lo, end);
  }

  proc SiftDown(start, end) {
    var root = start;
    while (root * 2 + 1 - lo <= end) {
      const child = root * 2 + 1 - lo;
      var swap = root;
      if chpl_sort_cmp(Data(swap), Data(child), reverse) then swap = child;
      if (child + 1 <= end) && (chpl_sort_cmp(Data(swap), Data(child + 1), reverse)) then swap = child + 1;
      if swap != root {
        Data(root) <=> Data(swap);
        root = swap;
      } else {
        return;
      }
    }
  }
  if (doublecheck) then VerifySort(Data, "HeapSort", reverse);
}

/*
   Sort the 1D array `Data` in-place using a sequential insertion sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc InsertionSort(Data: [?Dom] ?elType, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.low;
  for i in Dom {
    const ithVal = Data(i);
    var inserted = false;
    for j in lo..i-1 by -1 {
      if (chpl_sort_cmp(ithVal, Data(j), reverse)) {
        Data(j+1) = Data(j);
      } else {
        Data(j+1) = ithVal;
        inserted = true;
        break;
      }
    }
    if (!inserted) {
      Data(lo) = ithVal;
    }
  }

  if (doublecheck) then VerifySort(Data, "InsertionSort", reverse);
}

/*
   Sort the 1D array `Data` in-place using a parallel merge sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg minlen: When the array size is less than `minlen` use insertion sort algorithm
   :type minlen: integral
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc MergeSort(Data: [?Dom], minlen=16, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  _MergeSort(Data, minlen, reverse=reverse);
  if (doublecheck) then VerifySort(Data, "MergeSort", reverse);
}

pragma "no doc"
private proc _MergeSort(Data: [?Dom], minlen=16, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.dim(1).low;
  const hi = Dom.dim(1).high;
  if hi-lo < minlen {
    InsertionSort(Data, reverse=reverse);
    return;
  }
  const mid = (hi-lo)/2+lo;
  var A1 = Data[lo..mid];
  var A2 = Data[mid+1..hi];
  cobegin {
    { _MergeSort(A1, minlen, reverse=reverse); }
    { _MergeSort(A2, minlen, reverse=reverse); }
  }

  for (a, _a) in zip(Data[lo..hi], _MergeIterator(A1, A2, reverse=reverse)) do a = _a;
}

pragma "no doc"
private iter _MergeIterator(A1: [] ?elType, A2: [] elType, param reverse=false) {
  var a1 = A1.domain.dim(1).low;
  const a1hi = A1.domain.dim(1).high;
  var a2 = A2.domain.dim(1).low;
  const a2hi = A2.domain.dim(1).high;
  while ((a1 <= a1hi) && (a2 <= a2hi)) {
    while (chpl_sort_cmp(A1(a1) ,A2(a2), reverse, true)) {
      yield A1(a1);
      a1 += 1;
      if a1 > a1hi then break;
    }
    if a1 > a1hi then break;
    while (chpl_sort_cmp(A2(a2), A1(a1), reverse, true)) {
      yield A2(a2);
      a2 += 1;
      if a2 > a2hi then break;
    }
  }
  if a1 == a1hi then yield A1(a1);
  else if a2 == a2hi then yield A2(a2);
  if a1 < a1hi then for a in A1[a1..a1hi] do yield a;
  else if a2 < a2hi then for a in A2[a2..a2hi] do yield a;
}

/*
   Sort the 1D array `Data` in-place using a sequential quick sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg minlen: When the array size is less than `minlen` use insertion sort algorithm
   :type minlen: integral
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc QuickSort(Data: [?Dom] ?elType, minlen=16, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  // grab obvious indices
  const lo = Dom.low,
        hi = Dom.high,
        mid = lo + (hi-lo+1)/2;

  // base case -- use insertion sort
  if (hi - lo < minlen) {
    InsertionSort(Data, reverse=reverse);
    return;
  }

  // find pivot using median-of-3 method
  if (chpl_sort_cmp(Data(mid), Data(lo), reverse)) then Data(mid) <=> Data(lo);
  if (chpl_sort_cmp(Data(hi), Data(lo), reverse)) then Data(hi) <=> Data(lo);
  if (chpl_sort_cmp(Data(hi), Data(mid), reverse)) then Data(hi) <=> Data(mid);
  const pivotVal = Data(mid);
  Data(mid) = Data(hi-1);
  Data(hi-1) = pivotVal;
  // end median-of-3 partitioning

  var loptr = lo,
      hiptr = hi-1;
  while (loptr < hiptr) {
    do { loptr += 1; } while (chpl_sort_cmp(Data(loptr), pivotVal, reverse));
    do { hiptr -= 1; } while (chpl_sort_cmp(pivotVal, Data(hiptr), reverse));
    if (loptr < hiptr) {
      Data(loptr) <=> Data(hiptr);
    }
  }

  Data(hi-1) = Data(loptr);
  Data(loptr) = pivotVal;

  //  cobegin {
    QuickSort(Data[..loptr-1], reverse=reverse);  // could use unbounded ranges here
    QuickSort(Data[loptr+1..], reverse=reverse);
    //  }

  if (doublecheck) then VerifySort(Data, "QuickSort", reverse);
}

/*
   Sort the 1D array `Data` in-place using a sequential selection sort
   algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc SelectionSort(Data: [?Dom], doublecheck=false, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.dim(1).low;
  const hi = Dom.dim(1).high;
  for i in lo..hi-1 {
    var (_, loc) = if reverse then maxloc reduce zip(Data[i..hi], {i..hi})
      else minloc reduce zip(Data[i..hi], {i..hi});
    Data(i) <=> Data(loc);
  }

  if (doublecheck) then VerifySort(Data, "SelectionSort", reverse);
}

/*
   Verify that the array `Data` is in sorted order and halt if any element is
   out of order.

   :arg Data: The array to verify
   :type Data: [] eltType
   :arg str: string to print while halting if an element is out of order
   :type str: string
   :arg reverse: if true, expect the values to be sorted in reverse.
   :type reverse: bool

 */
inline proc VerifySort(Data: [?Dom] ?elType, str: string, param reverse=false) {
  for i in Dom.low..Dom.high-1 do
    if chpl_sort_cmp(Data(i+1), Data(i), reverse) then
      halt(str, " did not sort properly (", i, "): ", Data);
}

//
// This is a first draft "sorterator" which is designed to take some
// other iterator/iterable and yield its elements, in sorted order.
//
// The main limitations in the current code are (1) it should put some
// sort of constraint on 'x' to limit it to types for which this makes
// sense; and (2) there should be some generic way to say "y is an
// array of x's element type" (or to infer its element type) without
// saying a priori how big it is.  Without these mods, the result is
// that the sorterator works when it does and probably is confusing
// when it doesn't.
//
/*
   Yield the elements of argument `x` in sorted order.

   :arg x: An iterable value to be sorted and yielded element by element
   :type x: iterable

   :yields: The elements of x in sorted order
   :ytype: x's element type

 */
iter sorted(x) {
  var y = x;
  QuickSort(y);
  for i in y do
    yield i;
}
}

/*
 * Copyright 2004-2015 Cray Inc.
 * Other additional copyright holders may be indicated within.
 *
 * The entirety of this work is licensed under the Apache License,
 * Version 2.0 (the "License"); you may not use this file except
 * in compliance with the License.
 *
 * You may obtain a copy of the License at
 *
 *     http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 */

/*
   The `Sort` module is designed to support standard sorting
   routines.  The current interface is minimal and should be expected to
   grow and evolve over time. Each of the following functions accepts an
   optional boolean argument, `reverse`, which is `false` by
   default. If `true`, then the sort function will order in reverse.

 */
module Sort {

pragma "no doc"
inline proc chpl_sort_cmp(a, b, param reverse=false, param eq=false) {
  if eq {
    if reverse then return a >= b;
    else return a <= b;
  } else {
    if reverse then return a > b;
    else return a < b;
  }
}

/*
   Sort the 1D array `Data` in-place using a sequential bubble sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc BubbleSort(Data: [?Dom] ?elType, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.dim(1).low;
  const hi = Dom.dim(1).high;
  var swapped = true;

  while (swapped) {
    swapped = false;
    for i in lo..hi-1 {
      if !chpl_sort_cmp(Data(i), Data(i+1), reverse, true) {
        Data(i) <=> Data(i+1);
        swapped = true;
      }
    }
  }

  if (doublecheck) then VerifySort(Data, "BubbleSort", reverse);
}

/*
   Sort the 1D array `Data` in-place using a sequential heap sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] elType
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc HeapSort(Data: [?Dom] ?elType, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.dim(1).low;
  const hi = Dom.dim(1).high;
  const len = Dom.dim(1).size;

  // heapify
  var start = (len - 2) / 2 + lo;
  while (start >= lo) {
    SiftDown(start, hi);
    start = start - 1;
  }

  // sort, moving max element to end and re-heapifying the rest
  var end = hi;
  while (end > lo) {
    Data(end) <=> Data(lo);
    end = end - 1;
    SiftDown(lo, end);
  }

  proc SiftDown(start, end) {
    var root = start;
    while (root * 2 + 1 - lo <= end) {
      const child = root * 2 + 1 - lo;
      var swap = root;
      if chpl_sort_cmp(Data(swap), Data(child), reverse) then swap = child;
      if (child + 1 <= end) && (chpl_sort_cmp(Data(swap), Data(child + 1), reverse)) then swap = child + 1;
      if swap != root {
        Data(root) <=> Data(swap);
        root = swap;
      } else {
        return;
      }
    }
  }
  if (doublecheck) then VerifySort(Data, "HeapSort", reverse);
}

/*
   Sort the 1D array `Data` in-place using a sequential insertion sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc InsertionSort(Data: [?Dom] ?elType, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.low;
  for i in Dom {
    const ithVal = Data(i);
    var inserted = false;
    for j in lo..i-1 by -1 {
      if (chpl_sort_cmp(ithVal, Data(j), reverse)) {
        Data(j+1) = Data(j);
      } else {
        Data(j+1) = ithVal;
        inserted = true;
        break;
      }
    }
    if (!inserted) {
      Data(lo) = ithVal;
    }
  }

  if (doublecheck) then VerifySort(Data, "InsertionSort", reverse);
}

/*
   Sort the 1D array `Data` in-place using a parallel merge sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg minlen: When the array size is less than `minlen` use insertion sort algorithm
   :type minlen: integral
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc MergeSort(Data: [?Dom], minlen=16, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  _MergeSort(Data, minlen, reverse=reverse);
  if (doublecheck) then VerifySort(Data, "MergeSort", reverse);
}

pragma "no doc"
proc _MergeSort(Data: [?Dom], minlen=16, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.dim(1).low;
  const hi = Dom.dim(1).high;
  if hi-lo < minlen {
    InsertionSort(Data, reverse=reverse);
    return;
  }
  const mid = (hi-lo)/2+lo;
  var A1 = Data[lo..mid];
  var A2 = Data[mid+1..hi];
  cobegin {
    { _MergeSort(A1, minlen, reverse=reverse); }
    { _MergeSort(A2, minlen, reverse=reverse); }
  }

  for (a, _a) in zip(Data[lo..hi], _MergeIterator(A1, A2, reverse=reverse)) do a = _a;
}

pragma "no doc"
iter _MergeIterator(A1: [] ?elType, A2: [] elType, param reverse=false) {
  var a1 = A1.domain.dim(1).low;
  const a1hi = A1.domain.dim(1).high;
  var a2 = A2.domain.dim(1).low;
  const a2hi = A2.domain.dim(1).high;
  while ((a1 <= a1hi) && (a2 <= a2hi)) {
    while (chpl_sort_cmp(A1(a1) ,A2(a2), reverse, true)) {
      yield A1(a1);
      a1 += 1;
      if a1 > a1hi then break;
    }
    if a1 > a1hi then break;
    while (chpl_sort_cmp(A2(a2), A1(a1), reverse, true)) {
      yield A2(a2);
      a2 += 1;
      if a2 > a2hi then break;
    }
  }
  if a1 == a1hi then yield A1(a1);
  else if a2 == a2hi then yield A2(a2);
  if a1 < a1hi then for a in A1[a1..a1hi] do yield a;
  else if a2 < a2hi then for a in A2[a2..a2hi] do yield a;
}

/*
   Sort the 1D array `Data` in-place using a sequential quick sort algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg minlen: When the array size is less than `minlen` use insertion sort algorithm
   :type minlen: integral
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc QuickSort(Data: [?Dom] ?elType, minlen=16, doublecheck=false, param reverse=false) where Dom.rank == 1 {
  // grab obvious indices
  const lo = Dom.low,
        hi = Dom.high,
        mid = lo + (hi-lo+1)/2;

  // base case -- use insertion sort
  if (hi - lo < minlen) {
    InsertionSort(Data, reverse=reverse);
    return;
  }

  // find pivot using median-of-3 method
  if (chpl_sort_cmp(Data(mid), Data(lo), reverse)) then Data(mid) <=> Data(lo);
  if (chpl_sort_cmp(Data(hi), Data(lo), reverse)) then Data(hi) <=> Data(lo);
  if (chpl_sort_cmp(Data(hi), Data(mid), reverse)) then Data(hi) <=> Data(mid);
  const pivotVal = Data(mid);
  Data(mid) = Data(hi-1);
  Data(hi-1) = pivotVal;
  // end median-of-3 partitioning

  var loptr = lo,
      hiptr = hi-1;
  while (loptr < hiptr) {
    do { loptr += 1; } while (chpl_sort_cmp(Data(loptr), pivotVal, reverse));
    do { hiptr -= 1; } while (chpl_sort_cmp(pivotVal, Data(hiptr), reverse));
    if (loptr < hiptr) {
      Data(loptr) <=> Data(hiptr);
    }
  }

  Data(hi-1) = Data(loptr);
  Data(loptr) = pivotVal;

  //  cobegin {
    QuickSort(Data[..loptr-1], reverse=reverse);  // could use unbounded ranges here
    QuickSort(Data[loptr+1..], reverse=reverse);
    //  }

  if (doublecheck) then VerifySort(Data, "QuickSort", reverse);
}

/*
   Sort the 1D array `Data` in-place using a sequential selection sort
   algorithm.

   :arg Data: The array to be sorted
   :type Data: [] eltType
   :arg doublecheck: Verify the array is correctly sorted before returning
   :type doublecheck: bool
   :arg reverse: Sort in reverse numerical order
   :type reverse: bool

 */
proc SelectionSort(Data: [?Dom], doublecheck=false, param reverse=false) where Dom.rank == 1 {
  const lo = Dom.dim(1).low;
  const hi = Dom.dim(1).high;
  for i in lo..hi-1 {
    var (_, loc) = if reverse then maxloc reduce zip(Data[i..hi], {i..hi})
      else minloc reduce zip(Data[i..hi], {i..hi});
    Data(i) <=> Data(loc);
  }

  if (doublecheck) then VerifySort(Data, "SelectionSort", reverse);
}

/*
   Verify that the array `Data` is in sorted order and halt if any element is
   out of order.

   :arg Data: The array to verify
   :type Data: [] eltType
   :arg str: string to print while halting if an element is out of order
   :type str: string
   :arg reverse: if true, expect the values to be sorted in reverse.
   :type reverse: bool

 */
inline proc VerifySort(Data: [?Dom] ?elType, str: string, param reverse=false) {
  for i in Dom.low..Dom.high-1 do
    if chpl_sort_cmp(Data(i+1), Data(i), reverse) then
      halt(str, " did not sort properly (", i, "): ", Data);
}

//
// This is a first draft "sorterator" which is designed to take some
// other iterator/iterable and yield its elements, in sorted order.
//
// The main limitations in the current code are (1) it should put some
// sort of constraint on 'x' to limit it to types for which this makes
// sense; and (2) there should be some generic way to say "y is an
// array of x's element type" (or to infer its element type) without
// saying a priori how big it is.  Without these mods, the result is
// that the sorterator works when it does and probably is confusing
// when it doesn't.
//
/*
   Yield the elements of argument `x` in sorted order.

   :arg x: An iterable value to be sorted and yielded element by element
   :type x: iterable

   :yields: The elements of x in sorted order
   :ytype: x's element type

 */
iter sorted(x) {
  var y = x;
  QuickSort(y);
  for i in y do
    yield i;
}
}


Noticed an extraneous include when I was committing the reference version.
Reflected that change here.

git-svn-id: 88467cb1fb04b8a755be7e1ee1026be4190196ef@21977 3a8e244f-b0f2-452b-bcba-4c88e055c3ca

extern proc chpl_task_yield();

/*  - The Chameneos game is as follows:
      A population of n chameneos gathers at a common meeting place, where
      m meetings will take place (n and m may be distinct).  At any time, only
      one meeting may take place between exactly two chameneos, and each
      chameneos may be either blue, red, or yellow.  During a meeting, the
      chameneos exchange information about the other chameneos' color, so that
      after the meeting it can change its own color to the complement of its
      original color and the other chameneos' color.  (The complement is
      respective to two colors, its own and its partner's, such that if both
      colors are the same, no change, otherwise each chameneos changes to the
      color you and your partner both are not.)

    - (description of benchmark: http://shootout.alioth.debian.org/u32q/benchmark.php?test=chameneosredux&lang=all */

config const numMeetings : int = 6000000;  // number of meetings to take place
config const numChameneos1 : int(32) = 3;  // size of population 1
config const numChameneos2 : int(32) = 10; // size of population 2
enum Color {blue=0, red=1, yellow=2};
enum Digit {zero, one, two, three, four,
            five, six, seven, eight, nine};
config const verbose = false;
// if verbose is true, prints out non-det output, otherwise prints det output
config param CHAMENEOS_IDX_MASK = 0xFF: uint(32);
config param MEET_COUNT_SHIFT = 8;

class MeetingPlace {
  var state : atomic uint(32);

  /* constructor for MeetingPlace, sets the
     number of meetings to take place */
  proc MeetingPlace() {
    state.write((numMeetings << MEET_COUNT_SHIFT) : uint(32));
  }

  /* reset must be called after meet,
     to reset numMeetings for a subsequent call of meet */
  proc reset() {
    state.write((numMeetings << MEET_COUNT_SHIFT) : uint(32));
  }
}

/* getComplement returns the complement of this and another color:
   if this and the other color are of the same value, return own value
   otherwise return the color that is neither this or the other color */
inline proc getComplement(myColor : Color, otherColor : Color) {
  if (myColor == otherColor) {
    return myColor;
  }
  return (3 - myColor - otherColor) : Color;
}

class Chameneos {
  var id: int(32);
  var color : Color;
  var meetings : int;
  var meetingsWithSelf : int;
  var meetingCompleted : atomic bool;

  /* start tells a Chameneos to go to a given MeetingPlace, where it may meet
     with another Chameneos.  If it does, it will get the other's color and
     use this color and its own to compute the color both will have after the
     meeting has ended, setting both of their colors to this value. */
  proc start(population : [] Chameneos, meetingPlace: MeetingPlace) {
    var stateTemp : uint(32);
    var peer_idx : uint(32);
    var xchg : uint(32);

    stateTemp = meetingPlace.state.read(memory_order_acquire);

    while (true) {
      peer_idx = stateTemp & CHAMENEOS_IDX_MASK;
      if (peer_idx) {
        xchg = stateTemp - peer_idx - (1 << MEET_COUNT_SHIFT):uint(32);
      } else if (stateTemp) {
        xchg = stateTemp | id;
      } else {
        break;
      }
      if (meetingPlace.state.compareExchangeStrong(stateTemp, xchg, memory_order_acq_rel)) {
        if (peer_idx) {
          runMeeting(population, peer_idx);
        } else {
          // Attend meeting

          // This version uses waitFor instead of chpl_task_yield
          meetingCompleted.waitFor(true);

          meetingCompleted.write(false, memory_order_release);
          stateTemp = meetingPlace.state.read(memory_order_acquire);
        }
      } else {
        stateTemp = meetingPlace.state.read(memory_order_acquire);
      }
    }
  }

  /* Given the id of its peer, finds and updates the data of its peer and
     itself */
  proc runMeeting (population : [] Chameneos, peer_idx : uint(32)) {
    var peer : Chameneos;
    var is_same : int;
    var newColor : Color;
    if (id == peer_idx) {
      is_same = 1;
      halt("halt: chameneos met with self");
    }
    peer = population[peer_idx:int(32)];
    newColor = getComplement(color, peer.color);
    peer.color = newColor;
    peer.meetings += 1;
    peer.meetingsWithSelf += is_same;
    peer.meetingCompleted.write(true, memory_order_release);

    color = newColor;
    meetings += 1;
    meetingsWithSelf += is_same;
  }
}

/* printColorChanges prints the result of getComplement for all possible
   pairs of colors */
proc printColorChanges() {
  const colors : [1..3] Color = (Color.blue, Color.red, Color.yellow);
  for color1 in colors {
    for color2 in colors {
      writeln(color1, " + ", color2, " -> ", getComplement(color1, color2));
    }
  }
  writeln();
}

/* populate takes an parameter of type int, size, and returns a population of
   chameneos of that size. if population size is set to 10, will use preset
   array of colors  */
proc populate (size : int(32)) {
  const colorsDefault10  = (Color.blue, Color.red, Color.yellow, Color.red,
                            Color.yellow, Color.blue, Color.red, Color.yellow,
                            Color.red, Color.blue);
  const D : domain(1, int(32)) = {1..size};
  var population : [D] Chameneos;

  if (size == 10) {
    for i in D {
      population(i) = new Chameneos(i, colorsDefault10(i));
    }
  } else {
    for i in D {
      population(i) = new Chameneos(i, ((i-1) % 3):Color);
    }
  }
  return population;
}

/* run takes a population of Chameneos and a MeetingPlace, then allows the
   Chameneos to meet. It then prints out the number of times each Chameneos
   met another Chameneos, spells out the number of times it met with itself,
   then spells out the total number of times all the Chameneos met
   another Chameneos. */
proc run(population : [] Chameneos, meetingPlace : MeetingPlace) {
  for i in population {
    write(" ", i.color);
  }
  writeln();

  coforall i in population {
    i.start(population, meetingPlace);
  }

  meetingPlace.reset();
}

proc runQuiet(population : [] Chameneos, meetingPlace : MeetingPlace) {
  coforall i in population {
    i.start(population, meetingPlace);
  }
  meetingPlace.reset();

  const totalMeetings = + reduce population.meetings;
  const totalMeetingsWithSelf = + reduce population.meetingsWithSelf;
  if (totalMeetings == numMeetings*2) {
    writeln("total meetings PASS");
  } else {
    writeln("total meetings actual = ", totalMeetings, ", total meetings expected = ", numMeetings*2);
  }

  if (totalMeetingsWithSelf == 0) {
    writeln("total meetings with self PASS");
  } else {
    writeln("total meetings with self actual = ", totalMeetingsWithSelf, ", total meetings with self expected = 0");
  }

  writeln();
}

proc printInfo(population : [] Chameneos) {
  for i in population {
    write(i.meetings);
    spellInt(i.meetingsWithSelf);
  }
  const totalMeetings = + reduce population.meetings;
  spellInt(totalMeetings);
  writeln();
}

/* spellInt takes an integer, and spells each of its digits out in English */
proc spellInt(n : int) {
  var s : string = n:string;
  for i in 1..s.length {
    write(" ", (s.substring(i):int + 1):Digit);
  }
  writeln();
}

proc main() {
  if (numChameneos1 < 2 || numChameneos2 < 2 || numMeetings < 0) {
    writeln("Please specify numChameneos1 and numChameneos2 of at least 2, and numMeetings of at least 0.");
  } else  {
    printColorChanges();

    const forest : MeetingPlace = new MeetingPlace();

    const population1 = populate(numChameneos1);
    const population2 = populate(numChameneos2);

    if (verbose) {
      run(population1, forest);
      printInfo(population1);

      run(population2, forest);
      printInfo(population2);
    } else {
      runQuiet(population1, forest);
      runQuiet(population2, forest);
    }
  }
}


Made necessary refactoring for GlobalAtomicObject

/*
  Provides a software solution to the problem of applying atomic operations using
  128-bit wide pointers via compression. The algorithm used for compression (and
  decompression) rely on the number locales. In majority of cases where numLocales
  is within a 16 bit range, we can encode it in the upper 16 bits of the address
  as only 2^48 bits of the virtual address space is ever used. In the cases where
  numLocales is between 2^17 and 2^32, we use a novel but simple technique of
  maintaining 'tables' that can be indexed into via a 32-bit integer, allowing the
  other 32-bits to be used for the locale id. The table can be indexed without
  need of synchronization, but as a Chapel array cannot be operated on while it's
  domain is being updated, we use a simple `sync` variable locally and maintain
  32 segments that are allocated on demand. While descriptors are valid, the segment
  being indexed into will be safe to use without synchronization. A simple skip list
  is utilized to efficiently hash objects to their unique index.
*/

use BlockDist;
use Random;
use BigInteger;

// In the case where you want to use the descriptor table approach for testing or
// because there's some architecture which the assumption that only 48 bits are used
// for the virtual address space is incorrect, you can disable it here.
config param usePointerCompression = true;

// We require this to create a wide pointer after decompression.
extern type wide_ptr_t;
extern type c_nodeid_t;
extern proc chpl_return_wide_ptr_node(c_nodeid_t, c_void_ptr) : wide_ptr_t;

// Hashes a class instance by pointer. We ignore the locale id portion because
// this is used for pointers that refer into our address space.
inline proc hash(obj) : uint where isClass(obj.type) {
  var key =  __primitive("cast", uint(64), __primitive("_wide_get_addr", obj));
  key = (~key) + (key << 21); // key = (key << 21) - key - 1;
  key = key ^ (key >> 24);
  key = (key + (key << 3)) + (key << 8); // key * 265
  key = key ^ (key >> 14);
  key = (key + (key << 2)) + (key << 4); // key * 21
  key = key ^ (key >> 28);
  key = key + (key << 31);
  return key;
}

proc hash(obj) {
  halt("Obj to hash *must* be a class instance...");
}

/*
  The core `GlobalAtomicObject` which manages compression and decompression
  for atomic objects. It should be noted that if numLocales >= 2^17, then any
  object being operated on is added to the descriptor table, which will leak data
  if never freed with '_delete' (although if the memory is reused,
  so will the memory managed by this object). The descriptor table will be cleaned
  up automatically when this goes out of scope.
*/

const compressedAddrMask = 0x0000FFFFFFFFFFFF;
const compressedLocaleIdMask = 0xFFFF;
const tableLocaleIdMask = 0xFFFFFFFF;
const tableIdxMask = 0xFFFFFFFF;
const compressedLocIdOffset = 48;
const tableLocIdOffset = 32;

record GlobalAtomicObject {
  type objType;
  var _atomicVar : atomic uint(64);

  // We maintain a SkipList to manage memory (which is built on top of the descriptor
  // table itself). Currently, as the SkipList is not concurrent (requires Hazard Pointers
  // which requires thread-local storage, or task-local storage in this case).
  var perLocaleDomain = LocaleSpace dmapped Block(boundingBox=LocaleSpace);
  var descriptorTables : [perLocaleDomain] SkipList(objType);
  var descriptorTableLocks : [perLocaleDomain] sync bool;

  // Only if number of locales fits within 16 bits...
  inline proc shouldCompress {
    return usePointerCompression && (numLocales & compressedLocaleIdMask == numLocales);
  }

  inline proc getLocaleId(obj) {
    return chpl_nodeFromLocaleID(__primitive("_wide_get_locale", obj)) : uint;
  }

  inline proc getAddr(obj) {
    return __primitive("cast", uint, __primitive("_wide_get_addr", obj));
  }

  inline proc ourLocaleIdx {
    return perLocaleDomain.localSubdomain().first;
  }

  inline proc maxDescriptorTableLocaleCheck(locId) {
    if (locId & tableLocaleIdMask) != locId {
      halt("LocaleID: ", locId, " > 2^32");
    }
  }

  inline proc maxDescriptorTableIndexCheck(idx) {
    if (idx & tableIdxMask) != idx {
      halt("Idx: ", idx, " > 2^32");
    }
  }

  inline proc widePointerCheck(obj) {
    if !__primitive("is wide pointer", obj) {
      halt(
        "Dummy object created was not a wide pointer!",
        " Assumption: Inside a 'local' block"
      );
    }
  }

  inline proc uintToCVoidPtr(addr) {
    return __primitive("cast", c_void_ptr, addr);
  }

  /*
    Compresses an object into a descriptor.
  */
  proc compress(obj:objType) : uint {
    if obj == nil then return 0;

    // Perform a faster compression by packing the 48 usable bits of the virtual
    // address with 16 bits of the locale/node id.
    if shouldCompress {
      var locId = getLocaleId(obj);
      var addr = getAddr(obj);
      return (locId << compressedLocIdOffset) | (addr & compressedAddrMask);
    }

    // Fallback: We use descriptor tables
    var descriptor : uint;
    on obj {
      // Lock
      descriptorTableLocks[ourLocaleIdx] = true;

      // The skip list returns the node, which contains the table index.
      // We return a node instead of just the index for potential testing purposes.
      var node = descriptorTables[ourLocaleIdx].insert(obj);
      var locId = here.id;
      maxDescriptorTableLocaleCheck(locId);
      var idx = node.idx;
      maxDescriptorTableIndexCheck(idx);
      descriptor = locId << compressedLocIdOffset | idx;

      // Unlock
      descriptorTableLocks[ourLocaleIdx];
    }

    return descriptor;
  }

  /*
    Decompresses a descriptor into the wide pointer object.
  */
  proc decompress(descr:uint) : objType {
    if descr == 0 then return nil;

    // If we have less than 2^16 locales, then we know we performed the
    // faster compression method so we need to decompress it in the same way...
    if shouldCompress {
      var locId = descr >> compressedLocIdOffset;
      var addr = descr & compressedAddrMask;
      var wideptr = chpl_return_wide_ptr_node(locId, uintToCVoidPtr(addr));

      // We've created the wide pointer, but unfortunately Chapel does not support
      // the ability to cast it to the actual object, so we have to do some
      // trickery to get it to work. What we do is we allocate a wide pointer on
      // the stack and memcpy our wideptr into the other. This is needed so we
      // have the same type.
      var newObj : objType;
      on Locales[here.id] do newObj = nil;
      widePointerCheck(newObj);
      c_memcpy(c_ptrTo(newObj), c_ptrTo(wideptr), 16);

      return newObj;
    }

    // Fallback: Descriptor table was used, and we can directly index into the
    // the skip list's memory pool.
    var locId = descr >> tableLocIdOffset;
    var idx = descr & tableIdxMask;
    return descriptorTables[locId : int].memPool.access(idx : int).key;
  }

  inline proc read() : objType {
    return decompress(_atomicVar.read());
  }

  inline proc write(obj:objType) {
    _atomicVar.write(compress(obj));
  }

  inline proc exchange(obj:objType) : objType {
    return decompress(_atomicVar.exchange(compress(obj)));
  }

  // TODO: Save time by comparing the actual objects, not just the hash... if both
  // objects are remote, this is a *significant* cost.
  //  var currDescr = _atomicVar.read();
  //  var currObj = decompress(currDescr);
  //  if currObj == expectedObj then _atomicVar.compareExchangeStrong(currDescr, compress(newObj));
  inline proc compareExchange(expectedObj:objType, newObj:objType) : bool {
    return _atomicVar.compareExchangeStrong(compress(expectedObj), compress(newObj));
  }

  /*
    Deletes the object from our table so it may be recycled.
  */
  inline proc _delete(obj:objType) {
    if obj != nil then on obj {
      descriptorTableLocks[descriptorTableLocks.domain.localSubdomain().first] = true;
      descriptorTables[descriptorTables.domain.localSubdomain().first].remove(obj);
      descriptorTableLocks[descriptorTableLocks.domain.localSubdomain().first];
    }
  }
}

/*
  Skip List implementation

  TODO: This needs to be made concurrent or else this will be the bottleneck
  for our implementation. Hazard Pointers likely needed (this also would be a
  viable example for a need of per-locale garbage collection. Perhaps make it
  possible to declare a zone such that no wide-pointers can be generated and that
  data cannot escape such a zone. It'd be very useful for lock-free/wait-free
  data structures, and should make garbage collection possible if mark-and-sweep
  stop-the-world is *only* for the task inside of the zone. Then again, hazard
  pointers work too...)
*/

param globalAtomicObjectSkipListMaxLevel = 4;

class SkipListNode {
  type keyType;
  var hash : uint(64);
  var key : keyType;
  var idx : uint;
  var forward : globalAtomicObjectSkipListMaxLevel * SkipListNode(keyType);
}

record SkipList {
  type keyType;
  var level = 1;
  var header : SkipListNode(keyType);
  var memPool : FlatObjectPool(SkipListNode(keyType));

  proc SkipList(type keyType) {
    memPool = new FlatObjectPool(SkipListNode(keyType), lambda () { return new SkipListNode(keyType); });
    header = makeNode(level);
  }

  inline proc randomLevel() {
    var levelRNG = makeRandomStream(real);
    var _level = 1;
    while levelRNG.getNext() < 0.5 && _level < globalAtomicObjectSkipListMaxLevel {
      _level = _level + 1;
    }
    return _level;
  }

  // Recycle and clean before usage...
  inline proc makeNode(_level, hash : uint = 0, key : keyType = nil) : SkipListNode(keyType) {
    var (idx, node) = memPool.alloc();
    node.idx = idx : uint;
    node.hash = hash;
    node.key = key;
    for i in 1 .. globalAtomicObjectSkipListMaxLevel do node.forward[i] = nil;

    return node;
  }

  proc remove(key : keyType) {
    // We hash the object to remove from the list. Note: We do not take into
    // account the localeId, so the object *must* not be a wide pointer.
    var hashKey = hash(key);
    var update : globalAtomicObjectSkipListMaxLevel * SkipListNode(keyType);
    var currNode = header;
    var currLevel = level;

    // Start at higher level first...
    while currLevel >= 1 {
      // Maintain same level so long ourHashKey > theirHashKey
      while currNode.forward[currLevel] != nil && currNode.forward[currLevel].hash < hashKey {
        currNode = currNode.forward[currLevel];
      }

      // At this point, ourHashKey < theirHashKey meaning we can't travel along this level.
      // However, because we are before them, that means that we would forward to them (if
      // we were to insert ourselves)
      update[currLevel] = currNode;
      currLevel = currLevel - 1;
    }

    // At this point, we cannot traverse any further than the bottom level.
    currNode = currNode.forward[1];
    if currNode == nil || currNode.hash != hashKey {
      return;
    }

    // It is a match, prepare to delete it by bridging the gap...
    for i in 1 .. level {
      if update[i].forward[i] != currNode then break;
      update[i].forward[i] = currNode.forward[i];
    }

    // Recycle node
    memPool.dealloc(currNode.idx);

    // If we are the highest node in the list, then we can reduce it.
    while level > 1 && header.forward[level] == nil {
      level = level - 1;
    }
  }

  proc insert(key : keyType) : SkipListNode(keyType) {
    // We hash the object to insert into the list. Note: We do not take into
    // account the localeId, so the object *must* not be a wide pointer.
    var hashKey = hash(key);
    var update : globalAtomicObjectSkipListMaxLevel * SkipListNode(keyType);
    var currNode = header;
    var currLevel = level;

    // Start at higher level first...
    while currLevel >= 1 {
      // Maintain same level so long ourHashKey > theirHashKey
      while currNode.forward[currLevel] != nil && currNode.forward[currLevel].hash < hashKey {
        currNode = currNode.forward[currLevel];
      }

      // At this point, ourHashKey < theirHashKey meaning we can't travel along this level.
      // However, because we are before them, that means that we would forward to them (if
      // we were to insert ourselves)
      update[currLevel] = currNode;
      currLevel = currLevel - 1;
    }

    // At this point, we cannot traverse any further than the bottom level.
    // Note that in this application, if it already exists then we can safely
    // return it.
    currNode = currNode.forward[1];
    if currNode != nil && currNode.hash == hashKey {
      return currNode;
    }

    // It doesn't exist (yet), so create one with a randomized level...
    var newLevel = randomLevel();

    // If the new level exceeds the current, we need to ensure that we are
    // forwardable from the header...
    if newLevel > level {
      for i in level + 1 .. newLevel {
        update[i] = header;
      }
      level = newLevel;
    }

    // Create new node and splice in
    currNode = makeNode(newLevel, hashKey, key);

    // Bridging the gap...
    for i in 1 .. newLevel {
      currNode.forward[i] = update[i].forward[i];
      update[i].forward[i] = currNode;
    }

    return currNode;
  }

  proc ~SkipList() {
    // Deleting memory pool ensures all memory that has been allocated with it gets
    // destroyed as well.
    delete memPool;
  }
}

/*
  Our memory pool...

  In our implementation, we keep track of 32 segments that is managed by a
  bitmap (hence the *need* for big integer). Initially, we start as empty and
  expand readily on demand without ever really contracting (I.E freeing memory)
  so once an index points to a segment, it will always refer to valid memory,
  which is crucial to allowing reads to be wait-free. Allocating is as simple
  as finding the first free bit, and using the index of that bit (*not* the value)
  to locate the segment. Recycling is as simple as clearing the bit.

  Segments are interesting in that they work extremely well with bitmaps and also
  expands at a reasonable rate. To give an example, initially the size of the first
  segment is 1 (2^1 - 1), the size of the second is 3 (2^2 - 1), the third is
  7 (2^3 - 1), of which add up to less than 2^32. Not only do we get to nearly
  double our size each time, we get to manage in-use memory in constant time,
  and an index can easily index into the table without needing to do anything.

  Also note that currently there is no bounds checking, and it is up to the user
  to ensure that no more than 2^32 objects are added.

  Potential Application: If there is a bounded number of indexes for a domain, you
  can create segments ahead of time and use a similar allocation strategy. For example,
  a 64-bit integer can use 64 segments in a similar fashion and allow concurrent
  accesses during resizing. Iteration can iterate over all segments that are in use.
  Just an idea... would work for distributions too.
*/

class FlatObjectPoolSegment {
  type objType;
  var size : int;
  var data : [{0 .. size-1}] objType;
}

class FlatObjectPool {
  type objType;
  var spawnFn : func(objType); /* Creating from generic type workaround */
  var freeFn : func(objType, void);
  var bitmap : bigint;
  var segmentSpace = {1..32};
  var segments : [segmentSpace] FlatObjectPoolSegment(objType);

  inline proc findSegment(n) {
    var bit = 31;
    while bit > 0 {
      if n & (1 << bit) != 0 then break;
      bit = bit - 1;
    }

    return bit;
  }

  inline proc findSegmentIndex(n) {
    // If n is 1, then there is only one slot
    if n == 1 {
      return 0;
    }

    var mostSignificantBit = findSegment(n);
    return n & ((1 << mostSignificantBit) - 1);
  }

  proc alloc() : (int, objType) {
    // Find an open spot, but resize if one is not found...
    var firstFreeBit = bitmap.scan0(1) : int;
    bitmap.setbit(firstFreeBit);

    var seg = findSegment(firstFreeBit) + 1;
    var segIdx = findSegmentIndex(firstFreeBit);

    // First-Touch Allocation
    if segments[seg] == nil {
        segments[seg] = new FlatObjectPoolSegment(objType, (1 << (seg - 1)));
    }

    ref obj = segments[seg].data[segIdx];

    // Reuse if already allocated, otherwise allocate and use
    if obj == nil then obj = spawnFn();
    // Get by value...
    var retval = obj;

    return (firstFreeBit, retval);
  }

  proc dealloc(idx) {
    bitmap.clrbit(idx);
  }

  // Access by index. This is safe because segments are not freed after allocation
  // and so concurrent accesses will not invalidate a valid index.
  proc access(idx) : objType {
    return segments[findSegment(idx) + 1].data[findSegmentIndex(idx)];
  }

  proc FlatObjectPool(type objType, spawnFn = nil, freeFn = nil) {
    segments[1] = new FlatObjectPool(objType, 1);
  }

  proc ~FlatObjectPool() {
    for seg in segments {
      if seg != nil {
        for obj in seg.data {
          if obj != nil {
            if freeFn != nil {
              freeFn(obj);
            } else {
              delete obj;
            }
          }
        }
      }
    }
  }
}

proc multiLocaleTest() {
  class D { var d : int; }
  var arr : [{1..100}] D;
  for i in 1 .. 100 {
    on Locales[i % numLocales] do arr[i] = new D(i);
  }

  var x = new GlobalAtomicObject(D);
  x.write(arr[1]);

  for i in 1 .. 99 {
    assert(x.read() == arr[i]);
    var result = x.compareExchange(arr[i], arr[i+1]);
    assert(result);
    delete arr[i];
  }
}

proc singleLocaleTest() {
  class C { var c : int; }
  var a = new C(1);
  var b = new C(2);
  var x = new GlobalAtomicObject(C); // atomic C
  var result : bool;

  x.write(a);
  result = x.compareExchange(a, b);
  assert(result);
  assert(x.read() == b);

  // Note that you can call 'delete' on the object while having it still be present
  // in the descriptor table. This may be okay for most cases where memory is not
  // an issue since reused addresses will hash to the same node and that node will
  // already point to the valid object the user is attempting to insert. However if
  // memory is an issue, one can call '_delete' to ensure that the node itself is removed
  // and can be recycled for later use.
  delete a;
  delete b;

  // Is Safe because we only use the pointer itself. However, in cases where 'a' and 'b'
  // can be reused by the same GlobalAtomicObject, then this could cause undefined behavior
  // where another concurrent task adds the same pointer. In those cases, you should call
  // '_delete' before 'delete'.
  x._delete(a);
  x._delete(b);

  // As well, when GlobalAtomicObject goes out of scope, all nodes it had in use also
  // get deleted...
}

proc main() {
  writeln("Single Locale Test...");
  singleLocaleTest();
  writeln("Passed!");
  writeln("Multi Locale Test...");
  multiLocaleTest();
  writeln("Passed!");
}

/*
  Provides a software solution to the problem of applying atomic operations using
  128-bit wide pointers via compression. The algorithm used for compression (and
  decompression) rely on the number locales. In majority of cases where numLocales
  is within a 16 bit range, we can encode it in the upper 16 bits of the address
  as only 2^48 bits of the virtual address space is ever used. In the cases where
  numLocales is between 2^17 and 2^32, we use a novel but simple technique of
  maintaining 'tables' that can be indexed into via a 32-bit integer, allowing the
  other 32-bits to be used for the locale id. The table can be indexed without
  need of synchronization, but as a Chapel array cannot be operated on while it's
  domain is being updated, we use a simple `sync` variable locally and maintain
  32 segments that are allocated on demand. While descriptors are valid, the segment
  being indexed into will be safe to use without synchronization. A simple skip list
  is utilized to efficiently hash objects to their unique index.
*/

use CyclicDist;
use Random;
use BigInteger;

// In the case where you want to use the descriptor table approach for testing or
// because there's some architecture which the assumption that only 48 bits are used
// for the virtual address space is incorrect, you can disable it here.
config param usePointerCompression = true;

// We require this to create a wide pointer after decompression.
extern type wide_ptr_t;
extern type c_nodeid_t;
extern proc chpl_return_wide_ptr_node(c_nodeid_t, c_void_ptr) : wide_ptr_t;

// Hashes a class instance by pointer. We ignore the locale id portion because
// this is used for pointers that refer into our address space.
proc hash(obj) : uint where isClass(obj.type) {
  var key =  __primitive("cast", uint(64), __primitive("_wide_get_addr", obj));
  key = (~key) + (key << 21); // key = (key << 21) - key - 1;
  key = key ^ (key >> 24);
  key = (key + (key << 3)) + (key << 8); // key * 265
  key = key ^ (key >> 14);
  key = (key + (key << 2)) + (key << 4); // key * 21
  key = key ^ (key >> 28);
  key = key + (key << 31);
  return key;
}

proc hash(obj) {
  halt("Obj to hash *must* be a class instance...");
}

/*
  The core `GlobalAtomicObject` which manages compression and decompression
  for atomic objects. It should be noted that if numLocales >= 2^17, then any
  object being operated on is added to the descriptor table, which will leak data
  if never freed with '_delete' (although if the memory is reused,
  so will the memory managed by this object). The descriptor table will be cleaned
  up automatically when this goes out of scope.
*/
record GlobalAtomicObject {
  type objType;
  var _atomicVar: atomic uint(64);

  // We maintain a SkipList to manage memory (which is built on top of the descriptor
  // table itself). Currently, as the SkipList is not concurrent (requires Hazard Pointers
  // which requires thread-local storage, or task-local storage in this case).
  var perLocaleDomain = LocaleSpace dmapped Cyclic(startIdx=LocaleSpace.low);
  var descriptorTables : [perLocaleDomain] SkipList(objType);
  var descriptorTableLocks : [perLocaleDomain] sync bool;

  /*
    Compresses an object into a descriptor.
  */
  proc compress(obj:objType) : uint {
    if obj == nil then return 0;

    // If we have less than 2^16 locales, we can perform a faster compression
    // by packing the 48 usable bits of the virtual address with 16 bits of the
    // locale/node id.
    if usePointerCompression && (numLocales & 0xFFFF == numLocales) {
      var locId = chpl_nodeFromLocaleID(__primitive("_wide_get_locale", obj)) : uint;
      var addr = __primitive("cast", uint, __primitive("_wide_get_addr", obj));
      return locId << 48 | addr & 0x0000ffffffffffff;
    }

    // Fallback: We use descriptor tables
    var retval : uint;
    on obj {
      descriptorTableLocks[descriptorTableLocks.domain.localSubdomain().first] = true;
      var node = descriptorTables[descriptorTables.domain.localSubdomain().first].insert(obj);
      var localeId = here.id;
      if (localeId & 0xFFFFFFFF) != localeId then halt("LocaleID > 2^32");
      var idx = node.idx;
      if (idx & 0xFFFFFFFF) != idx then halt("Idx > 2^32");
      retval = localeId << 32 | idx;
      descriptorTableLocks[descriptorTableLocks.domain.localSubdomain().first];
    }

    return retval;
  }

  /*
    Decompresses a descriptor into the wide pointer object.
  */
  proc decompress(descr:uint) : objType {
    if descr == 0 then return nil;

    // If we have less than 2^16 locales, then we know we performed the
    // faster compression method so we need to decompress it in the same way...
    if usePointerCompression && (numLocales & 0xFFFF == numLocales) {
      var locId = descr >> 48;
      var addr = descr & 0x0000ffffffffffff;
      var wideptr = chpl_return_wide_ptr_node(locId, __primitive("cast", c_void_ptr, addr));

      // We've created the wide pointer, but unfortunately Chapel does not support
      // the ability to cast it to the actual object, so we have to do some
      // trickery to get it to work. What we do is we allocate a wide pointer on
      // the stack and memcpy our wideptr into the other. This is needed so we
      // have the same type.
      var newObj : objType;
      on Locales[here.id] do newObj = nil;

      // Warning: If this is *not* a wide pointer, it will overwrite part of the stack.
      // If it is, it works. Dangerous, but only way to do so at the moment.
      c_memcpy(c_ptrTo(newObj), c_ptrTo(wideptr), 16);
      return newObj;
    }

    var localeId = descr >> 32;
    var idx = descr & 0xFFFFFFFF;
    return descriptorTables[localeId : int].memPool.access(idx : int).key;
  }

  inline proc read() : objType {
    return decompress(_atomicVar.read());
  }

  inline proc write(obj:objType) {
    _atomicVar.write(compress(obj));
  }

  inline proc exchange(obj:objType) : objType {
    return decompress(_atomicVar.exchange(compress(obj)));
  }

  // TODO: Save time by comparing the actual objects, not just the hash... if both
  // objects are remote, this is a *significant* cost.
  //  var currDescr = _atomicVar.read();
  //  var currObj = decompress(currDescr);
  //  if currObj == expectedObj then _atomicVar.compareExchangeStrong(currDescr, compress(newObj));
  inline proc compareExchange(expectedObj:objType, newObj:objType) : bool {
    return _atomicVar.compareExchangeStrong(compress(expectedObj), compress(newObj));
  }

  /*
    Deletes the object from our table so it may be recycled.
  */
  inline proc _delete(obj:objType) {
    if obj != nil then on obj {
      descriptorTableLocks[descriptorTableLocks.domain.localSubdomain().first] = true;
      descriptorTables[descriptorTables.domain.localSubdomain().first].remove(obj);
      descriptorTableLocks[descriptorTableLocks.domain.localSubdomain().first];
    }
  }
}

class SkipListNode {
  type keyType;
  var hash : uint(64);
  var key : keyType;
  var idx : uint;
  var forwardDom : domain(int);
  var forward : [forwardDom] SkipListNode(keyType);
}

/*
  TODO: This needs to be made concurrent or else this will be the bottleneck
  for our implementation. Hazard Pointers likely needed (this also would be a
  viable example for a need of per-locale garbage collection. Perhaps make it
  possible to declare a zone such that no wide-pointers can be generated and that
  data cannot escape such a zone. It'd be very useful for lock-free/wait-free
  data structures, and should make garbage collection possible if mark-and-sweep
  stop-the-world is *only* for the task inside of the zone. Then again, hazard
  pointers work too...)
*/
record SkipList {
  type keyType;
  var maxLevel = 4;
  var level = 1;
  var header : SkipListNode(keyType);
  var memPool : FlatObjectPool(SkipListNode(keyType));

  proc SkipList(type keyType) {
    memPool = new FlatObjectPool(SkipListNode(keyType), lambda () { return new SkipListNode(keyType); });
    header = makeNode(level);
  }

  // RNG to create randomized level
  var randStr = makeRandomStream(real);

  inline proc randomLevel() {
    var _level = 1;
    while randStr.getNext() < 0.5 && _level < maxLevel {
      _level = _level + 1;
    }
    return _level;
  }

  // Recycle and clean before usage...
  inline proc makeNode(_level, hash : uint = 0, key : keyType = nil) : SkipListNode(keyType) {
    var (idx, node) = memPool.alloc();
    node.idx = idx : uint;
    node.hash = hash;
    node.key = key;
    node.forwardDom = { 1 .. maxLevel };
    node.forward = nil;

    return node;
  }

  proc remove(key : keyType) {
    // We hash the object to remove from the list. Note: We do not take into
    // account the localeId, so the object *must* not be a wide pointer.
    var hashKey = hash(key);
    var update : [{1 .. maxLevel}] SkipListNode(keyType);
    var currNode = header;
    var currLevel = level;

    // Start at higher level first...
    while currLevel >= 1 {
      // Maintain same level so long ourHashKey > theirHashKey
      while currNode.forward[currLevel] != nil && currNode.forward[currLevel].hash < hashKey {
        currNode = currNode.forward[currLevel];
      }

      // At this point, ourHashKey < theirHashKey meaning we can't travel along this level.
      // However, because we are before them, that means that we would forward to them (if
      // we were to insert ourselves)
      update[currLevel] = currNode;
      currLevel = currLevel - 1;
    }

    // At this point, we cannot traverse any further than the bottom level.
    currNode = currNode.forward[1];
    if currNode == nil || currNode.hash != hashKey {
      return;
    }

    // It is a match, prepare to delete it by bridging the gap...
    for i in 1 .. level {
      if update[i].forward[i] != currNode then break;
      update[i].forward[i] = currNode.forward[i];
    }

    // Recycle node
    memPool.dealloc(currNode.idx);

    // If we are the highest node in the list, then we can reduce it.
    while level > 1 && header.forward[level] == nil {
      level = level - 1;
    }
  }

  proc insert(key : keyType) : SkipListNode(keyType) {
    // We hash the object to insert into the list. Note: We do not take into
    // account the localeId, so the object *must* not be a wide pointer.
    var hashKey = hash(key);
    var update : [{1 .. maxLevel}] SkipListNode(keyType);
    var currNode = header;
    var currLevel = level;

    // Start at higher level first...
    while currLevel >= 1 {
      // Maintain same level so long ourHashKey > theirHashKey
      while currNode.forward[currLevel] != nil && currNode.forward[currLevel].hash < hashKey {
        currNode = currNode.forward[currLevel];
      }

      // At this point, ourHashKey < theirHashKey meaning we can't travel along this level.
      // However, because we are before them, that means that we would forward to them (if
      // we were to insert ourselves)
      update[currLevel] = currNode;
      currLevel = currLevel - 1;
    }

    // At this point, we cannot traverse any further than the bottom level.
    // Note that in this application, if it already exists then we can safely
    // return it.
    currNode = currNode.forward[1];
    if currNode != nil && currNode.hash == hashKey {
      return currNode;
    }

    // It doesn't exist (yet), so create one with a randomized level...
    var newLevel = randomLevel();

    // If the new level exceeds the current, we need to ensure that we are
    // forwardable from the header...
    if newLevel > level {
      for i in level + 1 .. newLevel {
        update[i] = header;
      }
      level = newLevel;
    }

    // Create new node and splice in
    currNode = makeNode(newLevel, hashKey, key);

    // Bridging the gap...
    for i in 1 .. newLevel {
      currNode.forward[i] = update[i].forward[i];
      update[i].forward[i] = currNode;
    }

    return currNode;
  }

  proc ~SkipList() {
    // Deleting memory pool ensures all memory that has been allocated with it gets
    // destroyed as well.
    delete memPool;
  }
}

/*
  Our memory pool...

  In our implementation, we keep track of 32 segments that is managed by a
  bitmap (hence the *need* for big integer). Initially, we start as empty and
  expand readily on demand without ever really contracting (I.E freeing memory)
  so once an index points to a segment, it will always refer to valid memory,
  which is crucial to allowing reads to be wait-free. Allocating is as simple
  as finding the first free bit, and using the index of that bit (*not* the value)
  to locate the segment. Recycling is as simple as clearing the bit.

  Segments are interesting in that they work extremely well with bitmaps and also
  expands at a reasonable rate. To give an example, initially the size of the first
  segment is 1 (2^1 - 1), the size of the second is 3 (2^2 - 1), the third is
  7 (2^3 - 1), of which add up to less than 2^32. Not only do we get to nearly
  double our size each time, we get to manage in-use memory in constant time,
  and an index can easily index into the table without needing to do anything.

  Also note that currently there is no bounds checking, and it is up to the user
  to ensure that no more than 2^32 objects are added.

  Potential Application: If there is a bounded number of indexes for a domain, you
  can create segments ahead of time and use a similar allocation strategy. For example,
  a 64-bit integer can use 64 segments in a similar fashion and allow concurrent
  accesses during resizing. Iteration can iterate over all segments that are in use.
  Just an idea... would work for distributions too.
*/

class FlatObjectPoolSegment {
  type objType;
  var size : int;
  var data : [{0 .. size-1}] objType;
}

class FlatObjectPool {
  type objType;
  var spawnFn : func(objType); /* Creating from generic type workaround */
  var freeFn : func(objType, void);
  var bitmap : bigint;
  var segmentSpace = {1..32};
  var segments : [segmentSpace] FlatObjectPoolSegment(objType);

  inline proc findSegment(n) {
    var bit = 31;
    while bit > 0 {
      if n & (1 << bit) != 0 then break;
      bit = bit - 1;
    }

    return bit;
  }

  inline proc findSegmentIndex(n) {
    // If n is 1, then there is only one slot
    if n == 1 {
      return 0;
    }

    var mostSignificantBit = findSegment(n);
    return n & ((1 << mostSignificantBit) - 1);
  }

  proc alloc() : (int, objType) {
    // Find an open spot, but resize if one is not found...
    var firstFreeBit = bitmap.scan0(1) : int;
    bitmap.setbit(firstFreeBit);

    var seg = findSegment(firstFreeBit) + 1;
    var segIdx = findSegmentIndex(firstFreeBit);

    // First-Touch Allocation
    if segments[seg] == nil {
        segments[seg] = new FlatObjectPoolSegment(objType, (1 << (seg - 1)));
    }

    ref obj = segments[seg].data[segIdx];

    // Reuse if already allocated, otherwise allocate and use
    if obj == nil then obj = spawnFn();
    // Get by value...
    var retval = obj;

    return (firstFreeBit, retval);
  }

  proc dealloc(idx) {
    bitmap.clrbit(idx);
  }

  // Access by index. This is safe because segments are not freed after allocation
  // and so concurrent accesses will not invalidate a valid index.
  proc access(idx) : objType {
    return segments[findSegment(idx) + 1].data[findSegmentIndex(idx)];
  }

  proc FlatObjectPool(type objType, spawnFn = nil, freeFn = nil) {
    segments[1] = new FlatObjectPool(objType, 1);
  }

  proc ~FlatObjectPool() {
    for seg in segments {
      if seg != nil {
        for obj in seg.data {
          if obj != nil {
            if freeFn != nil {
              freeFn(obj);
            } else {
              delete obj;
            }
          }
        }
      }
    }
  }
}

proc multiLocaleTest() {
  class D { var d : int; }
  var arr : [{1..100}] D;
  for i in 1 .. 100 {
    on Locales[i % numLocales] do arr[i] = new D(i);
  }

  var x = new GlobalAtomicObject(D);
  x.write(arr[1]);

  for i in 1 .. 99 {
    assert(x.read() == arr[i]);
    var result = x.compareExchange(arr[i], arr[i+1]);
    assert(result);
    delete arr[i];
  }
}

proc singleLocaleTest() {
  class C { var c : int; }
  var a = new C(1);
  var b = new C(2);
  var x = new GlobalAtomicObject(C); // atomic C
  var result : bool;

  x.write(a);
  result = x.compareExchange(a, b);
  assert(result);
  assert(x.read() == b);

  // Note that you can call 'delete' on the object while having it still be present
  // in the descriptor table. This may be okay for most cases where memory is not
  // an issue since reused addresses will hash to the same node and that node will
  // already point to the valid object the user is attempting to insert. However if
  // memory is an issue, one can call '_delete' to ensure that the node itself is removed
  // and can be recycled for later use.
  delete a;
  delete b;

  // Is Safe because we only use the pointer itself. However, in cases where 'a' and 'b'
  // can be reused by the same GlobalAtomicObject, then this could cause undefined behavior
  // where another concurrent task adds the same pointer. In those cases, you should call
  // '_delete' before 'delete'.
  x._delete(a);
  x._delete(b);

  // As well, when GlobalAtomicObject goes out of scope, all nodes it had in use also
  // get deleted...
}

proc main() {
  writeln("Single Locale Test...");
  singleLocaleTest();
  writeln("Passed!");
  writeln("Multi Locale Test...");
  multiLocaleTest();
  writeln("Passed!");
}