Trying to shorten running time of test to
lower probability of timeout on Sunos
until we eliminate promotion temps.

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

use Random;   // For random filling of the initial grid.

/* ======================================================================================================
 *
 * Finite difference: 2d grid averaging.

 *
 * This program computes the solution of a Laplace equation.
 *
 * ====================================================================================================== */

// Configuration variables for program:

config var
   check_step    = 10,       // Frequency of correctness reporting.
   eps           = 1.0e-6,   // Error tolerance.
   init_seed     = 12345,    // Random number generator seed.
   initial_spike = 1.0e6,    // For error checking.
   n             = 100,      // Size of computational grid.
   verbose       = true;     // Debug/printing control.

const

   // 2D neighbors:

   northwest = (-1, -1),
   north     = (-1,  0),
   northeast = (-1,  1),
   west      = ( 0, -1),
   east      = ( 0,  1),
   southwest = ( 1, -1),
   south     = ( 1,  0),
   southeast = ( 1,  1),

   // 3D neighbors:

   frontnorthwest  = (-1, -1, 1),
   frontnorth      = (-1,  0, 1),
   frontnortheast  = (-1,  1, 1),
   frontwest       = ( 0, -1, 1),
   front           = ( 0,  0, 1),
   fronteast       = ( 0,  1, 1),
   frontsouthwest  = ( 1, -1, 1),
   frontsouth      = ( 1,  0, 1),
   frontsoutheast  = ( 1,  1, 1),

   centernorthwest = (-1, -1, 0),
   centernorth     = (-1,  0, 0),
   centernortheast = (-1,  1, 0),
   centerwest      = ( 0, -1, 0),
   centereast      = ( 0,  1, 0),
   centersouthwest = ( 1, -1, 0),
   centersouth     = ( 1,  0, 0),
   centersoutheast = ( 1,  1, 0),

   backnorthwest   = (-1, -1, -1),
   backnorth       = (-1,  0, -1),
   backnortheast   = (-1,  1, -1),
   backwest        = ( 0, -1, -1),
   back            = ( 0,  0, -1),
   backeast        = ( 0,  1, -1),
   backsouthwest   = ( 1, -1, -1),
   backsouth       = ( 1,  0, -1),
   backsoutheast   = ( 1,  1, -1);

/* ====================================================================================================== */
/*                                               Main program.                                            */
/* ====================================================================================================== */

def main() {

   /* ------------ */
   /* Declarations */
   /* ------------ */

   const ProblemSpace2d = [1..n, 1..n],       // domain for interior grid points
         BigDomain2d    = [0..n+1, 0..n+1];   // domain with boundary points

   var
      max_iter = 60;                      // Maximum number of iterations.

   var
      grid1,   //
      grid2 :  //
         [BigDomain2d] real = 0.0;

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Initialize grid1.

   if ( verbose )
      {
         var
            spike_loc_i = (n+2) / 2,       // Row location of initial heat source.
            spike_loc_j = (n+2) / 2;       // Column location of initial heat source.

            grid1 = 0.0;
            grid1[spike_loc_i, spike_loc_j] = initial_spike;
      }
   else
      {
         fillRandom(grid1, init_seed );
         // fillRandom(grid1, init_seed );  Not yet implemented.
      }

   var
      iteration = 1;                      // iteration counter

   // Iterate.

   writeln ( "\n ** Begin iteration ** \n" );

   do
      {
         /* ------------------------------------------- */
         /* Compute next approximation, store in grid2. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptA ( ProblemSpace2d, grid2, grid1, iteration );
         iteration += 1;

         /* ------------------------------------------- */
         /* Compute next approximation, store in grid1. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptA ( ProblemSpace2d, grid1, grid2, iteration );

     // Advance iteration counter.

     iteration += 1;

   } while ( iteration <= max_iter );

   if ( verbose )
      {
         var
            spike_loc_i = (n+2) / 2,       // Row location of initial heat source.
            spike_loc_j = (n+2) / 2;       // Column location of initial heat source.

            grid1 = 0.0;
            grid1[spike_loc_i, spike_loc_j] = initial_spike;
      }
   else
      {
         fillRandom(grid1, init_seed );
         // fillRandom(grid1, init_seed );  Not yet implemented.
      }

      iteration = 1;                      // iteration counter

   // Iterate.

   writeln ( "\n ** Begin iteration ** \n" );

   do
      {
         /* ------------------------------------------- */
         /* Compute next approximation, store in grid2. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptB ( ProblemSpace2d, grid2, grid1, iteration );
         iteration += 1;

         /* ------------------------------------------- */
         /* Compute next approximation, store in grid1. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptB ( ProblemSpace2d, grid1, grid2, iteration );

     // Advance iteration counter.

     iteration += 1;

   } while ( iteration <= max_iter );

   if ( verbose )
      {
         var
            spike_loc_i = (n+2) / 2,       // Row location of initial heat source.
            spike_loc_j = (n+2) / 2;       // Column location of initial heat source.

            grid1 = 0.0;
            grid1[spike_loc_i, spike_loc_j] = initial_spike;
      }
   else
      {
         fillRandom(grid1, init_seed );
         // fillRandom(grid1, init_seed );  Not yet implemented.
      }

      iteration = 1;                      // iteration counter

   // Iterate.

   writeln ( "\n ** Begin iteration ** \n" );

   do
      {
         /* ------------------------------------------- */
         /* Compute next approximation, store in grid2. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptC ( ProblemSpace2d, grid2, grid1, iteration );
         iteration += 1;

         /* ------------------------------------------- */
         /* Compute next approximation, store in grid1. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptC ( ProblemSpace2d, grid1, grid2, iteration );

     // Advance iteration counter.

     iteration += 1;

   } while ( iteration <= max_iter );

   if ( verbose )
      {
         var
            spike_loc_i = (n+2) / 2,       // Row location of initial heat source.
            spike_loc_j = (n+2) / 2;       // Column location of initial heat source.

            grid1 = 0.0;
            grid1[spike_loc_i, spike_loc_j] = initial_spike;
      }
   else
      {
         fillRandom(grid1, init_seed );
         // fillRandom(grid1, init_seed );  Not yet implemented.
      }

      iteration = 1;                      // iteration counter

   // Iterate.

   writeln ( "\n ** Begin iteration ** \n" );

   do
      {
         /* ------------------------------------------- */
         /* Compute next approximation, store in grid2. */
         /* ------------------------------------------- */

         ApplyStencil2d9pt ( ProblemSpace2d, grid2, grid1, iteration );
         iteration += 1;

         /* ------------------------------------------- */
         /* Compute next approximation, store in grid1. */
         /* ------------------------------------------- */

         ApplyStencil2d9pt ( ProblemSpace2d, grid1, grid2, iteration );

     // Advance iteration counter.

     iteration += 1;

   } while ( iteration <= max_iter );

   writeln("\n ** Iteration complete ** \n" );

} // End main program.

/* ====================================================================================================== */

def ApplyStencil2d5ptA ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 5-point difference stencil in 2d domain.

   forall (i,j) in ProblemSpace2d do

      newGrid(i,j) = (                 oldGrid(i-1,j) +
                      oldGrid(i,j-1) + oldGrid(  i,j) + oldGrid(i,j+1) +
                                       oldGrid(i+1,j)                    )
                   / 5.0;
   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil2d5ptA.

/* ====================================================================================================== */

def ApplyStencil2d5ptB ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 5-point difference stencil in 2d domain.

   forall ij in ProblemSpace2d do

      newGrid(ij) = (                     oldGrid(ij+(-1,0)) +
                     oldGrid(ij+(0,-1)) + oldGrid(ij)        + oldGrid(ij+(0,1)) +
                                          oldGrid(ij+(1,0))
                    ) / 5.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil2d5ptB.

/* ====================================================================================================== */

def ApplyStencil2d5ptC ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 5-point difference stencil in 2d domain.

   forall ij in ProblemSpace2d do

      newGrid(ij) = (                   oldGrid(ij+north) +
                     oldGrid(ij+west) + oldGrid(ij)       + oldGrid(ij+east)     +
                                        oldGrid(ij+south)                    )
                  / 5.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil2d5ptC.

/* ====================================================================================================== */

def ApplyStencil2d9pt ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 9-point difference stencil in 2d domain.

   forall ij in ProblemSpace2d do

      newGrid(ij) = ( oldGrid(ij+northwest) + oldGrid(ij+north) + oldGrid(ij+northeast)     +
                      oldGrid(ij+west)      + oldGrid(ij)       + oldGrid(ij+east)          +
                      oldGrid(ij+southwest) + oldGrid(ij+south) + oldGrid(ij+southeast)   )
                  / 9.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil2d5pt.

/* ====================================================================================================== */

def ApplyStencil3d7pt ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 7-point difference stencil to 3d domain.

   forall ijk in ProblemSpace2d do

      newGrid(ijk) = (                               oldGrid(ijk+back)                 +
                                           oldGrid(ijk+north)                          +
                      oldGrid(ijk+west)  + oldGrid(ijk)        + oldGrid(ijk+east)     +
                                           oldGrid(ijk+south)  +
                                    oldGrid(ijk+front)                               )

                  / 7.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil3d7pt.

/* ====================================================================================================== */

def ApplyStencil3d27pt ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 27-point difference stencil to 3d domain.

   forall ijk in ProblemSpace2d do

      newGrid(ijk) = (
                                 oldGrid(ijk+backnorthwest)  + oldGrid(ijk+backnorth)  + oldGrid(ijk+backnortheast) +
                                 oldGrid(ijk+backwest)       + oldGrid(ijk)            + oldGrid(ijk+backeast)      +
                                 oldGrid(ijk+backsouthwest)  + oldGrid(ijk+backsouth)  + oldGrid(ijk+backsoutheast) +

                           oldGrid(ijk+northwest)      + oldGrid(ijk+north)      + oldGrid(ijk+northeast)           +
                           oldGrid(ijk+west)           + oldGrid(ijk)            + oldGrid(ijk+east)                +
                           oldGrid(ijk+southwest)      + oldGrid(ijk+south)      + oldGrid(ijk+southeast)           +

                     oldGrid(ijk+frontnorthwest) + oldGrid(ijk+frontnorth) + oldGrid(ijk+frontnortheast)            +
                     oldGrid(ijk+frontwest)      + oldGrid(ijk)            + oldGrid(ijk+fronteast)                 +
                     oldGrid(ijk+frontsouthwest) + oldGrid(ijk+frontsouth) + oldGrid(ijk+frontsoutheast) )

                  / 27.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil3d27pt.

/* ====================================================================================================== */

def CheckAnswer ( ProblemSpace2d, newGrid, iteration ) {

   /* ------------------ */
   /* Local Declarations */
   /* ------------------ */

   var
      err : real;  // Computed error.

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   if ( verbose )
      {
         if ( iteration < ( n : real / 2.0 ) : int )
            {
               const sum = + reduce newGrid[ProblemSpace2d];
               err = initial_spike - sum;
               if ( abs ( err ) > eps )
                  {
                     writeln ( " ** Error ** diffuse2d, after ", iteration, " iterations; (error = ", err, ")" );
                  }
               else if ( iteration % check_step == 0 )
                  {
                     writeln ( " Iteration correct after ", iteration, " steps." );
                  }
            }
         else
            {
/*
               const sum = + reduce newGrid[ProblemSpace2d];
               writeln ( sum );
*/
            }
      }
} // End function ApplyStencil2d5pt.

/* ====================================================================================================== */
/* End diffuse2d.c                                                                                */
/* ====================================================================================================== */

def +(x:2*int, y:2*int) {
  var res:2*int;
  for param i in 1..2 do
    res(i) = x(i) + y(i);
  return res;
}

def +(x:3*int, y:3*int) {
  var res:3*int;
  for param i in 1..3 do
    res(i) = x(i) + y(i);
  return res;
}

use Random;   // For random filling of the initial grid.

/* ======================================================================================================
 *
 * Finite difference: 2d grid averaging.

 *
 * This program computes the solution of a Laplace equation.
 *
 * ====================================================================================================== */

// Configuration variables for program:

config var
   check_step    = 10,       // Frequency of correctness reporting.
   eps           = 1.0e-6,   // Error tolerance.
   init_seed     = 12345,    // Random number generator seed.
   initial_spike = 1.0e6,    // For error checking.
   n             = 100,      // Size of computational grid.
   verbose       = true;     // Debug/printing control.

const

   // 2D neighbors:

   northwest = (-1, -1),
   north     = (-1,  0),
   northeast = (-1,  1),
   west      = ( 0, -1),
   east      = ( 0,  1),
   southwest = ( 1, -1),
   south     = ( 1,  0),
   southeast = ( 1,  1),

   // 3D neighbors:

   frontnorthwest  = (-1, -1, 1),
   frontnorth      = (-1,  0, 1),
   frontnortheast  = (-1,  1, 1),
   frontwest       = ( 0, -1, 1),
   front           = ( 0,  0, 1),
   fronteast       = ( 0,  1, 1),
   frontsouthwest  = ( 1, -1, 1),
   frontsouth      = ( 1,  0, 1),
   frontsoutheast  = ( 1,  1, 1),

   centernorthwest = (-1, -1, 0),
   centernorth     = (-1,  0, 0),
   centernortheast = (-1,  1, 0),
   centerwest      = ( 0, -1, 0),
   centereast      = ( 0,  1, 0),
   centersouthwest = ( 1, -1, 0),
   centersouth     = ( 1,  0, 0),
   centersoutheast = ( 1,  1, 0),

   backnorthwest   = (-1, -1, -1),
   backnorth       = (-1,  0, -1),
   backnortheast   = (-1,  1, -1),
   backwest        = ( 0, -1, -1),
   back            = ( 0,  0, -1),
   backeast        = ( 0,  1, -1),
   backsouthwest   = ( 1, -1, -1),
   backsouth       = ( 1,  0, -1),
   backsoutheast   = ( 1,  1, -1);

/* ====================================================================================================== */
/*                                               Main program.                                            */
/* ====================================================================================================== */

def main() {

   /* ------------ */
   /* Declarations */
   /* ------------ */

   const ProblemSpace2d = [1..n, 1..n],       // domain for interior grid points
         BigDomain2d    = [0..n+1, 0..n+1];   // domain with boundary points

   var
      max_iter = 100;                      // Maximum number of iterations.

   var
      grid1,   //
      grid2 :  //
         [BigDomain2d] real = 0.0;

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Initialize grid1.

   if ( verbose )
      {
         var
            spike_loc_i = (n+2) / 2,       // Row location of initial heat source.
            spike_loc_j = (n+2) / 2;       // Column location of initial heat source.

            grid1 = 0.0;
            grid1[spike_loc_i, spike_loc_j] = initial_spike;
      }
   else
      {
         fillRandom(grid1, init_seed );
         // fillRandom(grid1, init_seed );  Not yet implemented.
      }

   var
      iteration = 1;                      // iteration counter

   // Iterate.

   writeln ( "\n ** Begin iteration ** \n" );

   do
      {
         /* ------------------------------------------- */
         /* Compute next approximation, store in grid2. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptA ( ProblemSpace2d, grid2, grid1, iteration );
         iteration += 1;

         /* ------------------------------------------- */
         /* Compute next approximation, store in grid1. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptA ( ProblemSpace2d, grid1, grid2, iteration );

     // Advance iteration counter.

     iteration += 1;

   } while ( iteration <= max_iter );

   if ( verbose )
      {
         var
            spike_loc_i = (n+2) / 2,       // Row location of initial heat source.
            spike_loc_j = (n+2) / 2;       // Column location of initial heat source.

            grid1 = 0.0;
            grid1[spike_loc_i, spike_loc_j] = initial_spike;
      }
   else
      {
         fillRandom(grid1, init_seed );
         // fillRandom(grid1, init_seed );  Not yet implemented.
      }

      iteration = 1;                      // iteration counter

   // Iterate.

   writeln ( "\n ** Begin iteration ** \n" );

   do
      {
         /* ------------------------------------------- */
         /* Compute next approximation, store in grid2. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptB ( ProblemSpace2d, grid2, grid1, iteration );
         iteration += 1;

         /* ------------------------------------------- */
         /* Compute next approximation, store in grid1. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptB ( ProblemSpace2d, grid1, grid2, iteration );

     // Advance iteration counter.

     iteration += 1;

   } while ( iteration <= max_iter );

   if ( verbose )
      {
         var
            spike_loc_i = (n+2) / 2,       // Row location of initial heat source.
            spike_loc_j = (n+2) / 2;       // Column location of initial heat source.

            grid1 = 0.0;
            grid1[spike_loc_i, spike_loc_j] = initial_spike;
      }
   else
      {
         fillRandom(grid1, init_seed );
         // fillRandom(grid1, init_seed );  Not yet implemented.
      }

      iteration = 1;                      // iteration counter

   // Iterate.

   writeln ( "\n ** Begin iteration ** \n" );

   do
      {
         /* ------------------------------------------- */
         /* Compute next approximation, store in grid2. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptC ( ProblemSpace2d, grid2, grid1, iteration );
         iteration += 1;

         /* ------------------------------------------- */
         /* Compute next approximation, store in grid1. */
         /* ------------------------------------------- */

         ApplyStencil2d5ptC ( ProblemSpace2d, grid1, grid2, iteration );

     // Advance iteration counter.

     iteration += 1;

   } while ( iteration <= max_iter );

   if ( verbose )
      {
         var
            spike_loc_i = (n+2) / 2,       // Row location of initial heat source.
            spike_loc_j = (n+2) / 2;       // Column location of initial heat source.

            grid1 = 0.0;
            grid1[spike_loc_i, spike_loc_j] = initial_spike;
      }
   else
      {
         fillRandom(grid1, init_seed );
         // fillRandom(grid1, init_seed );  Not yet implemented.
      }

      iteration = 1;                      // iteration counter

   // Iterate.

   writeln ( "\n ** Begin iteration ** \n" );

   do
      {
         /* ------------------------------------------- */
         /* Compute next approximation, store in grid2. */
         /* ------------------------------------------- */

         ApplyStencil2d9pt ( ProblemSpace2d, grid2, grid1, iteration );
         iteration += 1;

         /* ------------------------------------------- */
         /* Compute next approximation, store in grid1. */
         /* ------------------------------------------- */

         ApplyStencil2d9pt ( ProblemSpace2d, grid1, grid2, iteration );

     // Advance iteration counter.

     iteration += 1;

   } while ( iteration <= max_iter );

   writeln("\n ** Iteration complete ** \n" );

} // End main program.

/* ====================================================================================================== */

def ApplyStencil2d5ptA ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 5-point difference stencil in 2d domain.

   forall (i,j) in ProblemSpace2d do

      newGrid(i,j) = (                 oldGrid(i-1,j) +
                      oldGrid(i,j-1) + oldGrid(  i,j) + oldGrid(i,j+1) +
                                       oldGrid(i+1,j)                    )
                   / 5.0;
   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil2d5ptA.

/* ====================================================================================================== */

def ApplyStencil2d5ptB ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 5-point difference stencil in 2d domain.

   forall ij in ProblemSpace2d do

      newGrid(ij) = (                     oldGrid(ij+(-1,0)) +
                     oldGrid(ij+(0,-1)) + oldGrid(ij)        + oldGrid(ij+(0,1)) +
                                          oldGrid(ij+(1,0))
                    ) / 5.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil2d5ptB.

/* ====================================================================================================== */

def ApplyStencil2d5ptC ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 5-point difference stencil in 2d domain.

   forall ij in ProblemSpace2d do

      newGrid(ij) = (                   oldGrid(ij+north) +
                     oldGrid(ij+west) + oldGrid(ij)       + oldGrid(ij+east)     +
                                        oldGrid(ij+south)                    )
                  / 5.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil2d5ptC.

/* ====================================================================================================== */

def ApplyStencil2d9pt ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 9-point difference stencil in 2d domain.

   forall ij in ProblemSpace2d do

      newGrid(ij) = ( oldGrid(ij+northwest) + oldGrid(ij+north) + oldGrid(ij+northeast)     +
                      oldGrid(ij+west)      + oldGrid(ij)       + oldGrid(ij+east)          +
                      oldGrid(ij+southwest) + oldGrid(ij+south) + oldGrid(ij+southeast)   )
                  / 9.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil2d5pt.

/* ====================================================================================================== */

def ApplyStencil3d7pt ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 7-point difference stencil to 3d domain.

   forall ijk in ProblemSpace2d do

      newGrid(ijk) = (                               oldGrid(ijk+back)                 +
                                           oldGrid(ijk+north)                          +
                      oldGrid(ijk+west)  + oldGrid(ijk)        + oldGrid(ijk+east)     +
                                           oldGrid(ijk+south)  +
                                    oldGrid(ijk+front)                               )

                  / 7.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil3d7pt.

/* ====================================================================================================== */

def ApplyStencil3d27pt ( ProblemSpace2d, newGrid, oldGrid, iteration ) {

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   // Apply 27-point difference stencil to 3d domain.

   forall ijk in ProblemSpace2d do

      newGrid(ijk) = (
                                 oldGrid(ijk+backnorthwest)  + oldGrid(ijk+backnorth)  + oldGrid(ijk+backnortheast) +
                                 oldGrid(ijk+backwest)       + oldGrid(ijk)            + oldGrid(ijk+backeast)      +
                                 oldGrid(ijk+backsouthwest)  + oldGrid(ijk+backsouth)  + oldGrid(ijk+backsoutheast) +

                           oldGrid(ijk+northwest)      + oldGrid(ijk+north)      + oldGrid(ijk+northeast)           +
                           oldGrid(ijk+west)           + oldGrid(ijk)            + oldGrid(ijk+east)                +
                           oldGrid(ijk+southwest)      + oldGrid(ijk+south)      + oldGrid(ijk+southeast)           +

                     oldGrid(ijk+frontnorthwest) + oldGrid(ijk+frontnorth) + oldGrid(ijk+frontnortheast)            +
                     oldGrid(ijk+frontwest)      + oldGrid(ijk)            + oldGrid(ijk+fronteast)                 +
                     oldGrid(ijk+frontsouthwest) + oldGrid(ijk+frontsouth) + oldGrid(ijk+frontsoutheast) )

                  / 27.0;

   // Check answer.

   CheckAnswer ( ProblemSpace2d, newGrid, iteration );

} // End function ApplyStencil3d27pt.

/* ====================================================================================================== */

def CheckAnswer ( ProblemSpace2d, newGrid, iteration ) {

   /* ------------------ */
   /* Local Declarations */
   /* ------------------ */

   var
      err : real;  // Computed error.

   /* --------------------- */
   /* Executable Statements */
   /* --------------------- */

   if ( verbose )
      {
         if ( iteration < ( n : real / 2.0 ) : int )
            {
               const sum = + reduce newGrid[ProblemSpace2d];
               err = initial_spike - sum;
               if ( abs ( err ) > eps )
                  {
                     writeln ( " ** Error ** diffuse2d, after ", iteration, " iterations; (error = ", err, ")" );
                  }
               else if ( iteration % check_step == 0 )
                  {
                     writeln ( " Iteration correct after ", iteration, " steps." );
                  }
            }
         else
            {
/*
               const sum = + reduce newGrid[ProblemSpace2d];
               writeln ( sum );
*/
            }
      }
} // End function ApplyStencil2d5pt.

/* ====================================================================================================== */
/* End diffuse2d.c                                                                                */
/* ====================================================================================================== */

def +(x:2*int, y:2*int) {
  var res:2*int;
  for param i in 1..2 do
    res(i) = x(i) + y(i);
  return res;
}

def +(x:3*int, y:3*int) {
  var res:3*int;
  for param i in 1..3 do
    res(i) = x(i) + y(i);
  return res;
}


removing core.chpl

removing core.chpl

module Core {
  use Random;
  enum labelReplacementType {none, inverseDegree};

  /*
   Class to hold labels for data.  Has names in names
   */
  class LabelMatrix {
    var ldom: domain(1) = {1..0},
        dataDom: domain(2),                         // # records X # distinct labels
        nLabelValues: int = 0,                      // How many different labels are there?
        data: [dataDom] real,
        names: [ldom] string,
        trainingLabelDom: sparse subdomain(ldom);   // Which labels are training labels, for error analysis

    /*
    Loads a label file into a Matrix.  Labels should be binary indicators
    useCols: use columns for the labels, as in an indicator for each column.
             default is to have an integer representing the label
             <TAB> separated
    <record id: string> <category 1 indicator> ... <category L indicator>
     */
    proc readFromFile(fn: string, addDummy: bool = false, useCols=false) {
      var lFile = open(fn, iomode.r).reader(),
          x: [1..0] real,
          nFields: int,
          line: string,
          //ldom: domain(1),
          xline: [ldom] real,
          nRows: int = 1,
          firstLine: bool = true;
      if useCols {
        for line in lFile.lines() {
           var fields = line.split("\t");
           if firstLine {
             nFields = fields.size;
             if addDummy {
               ldom = {1..nFields};
             } else {
               ldom = {1..nFields-1};
             }
             dataDom = {1..0, 1..nFields};
             firstLine = false;
           } else {
             if fields.size != nFields {
               halt("Unequal number of fields in label file");
             }
           }
           ldom = {1..ldom.last+1};
           names[ldom.last] = fields[1];
           dataDom = { 1..#nRows, ldom.dim(1)};
           var xline: [ldom] real;
           for v in 2..fields.size {
             xline = fields[v]:real;
           }
           data[dataDom.last(1), ..] = xline;
           nRows += 1;
         }
       } else {
         // Getting integers for labels, then expanding to columns as new values arise
         ldom = {1..0};
         dataDom = {1..ldom.last, 1..1};
         var nLabels = 1;
         for line in lFile.lines() {
           ldom = {1..ldom.last+1};
           var fields = line.split("\t");
           names[ldom.last] = fields[1]:string;
           if fields[2]:int > nLabels {
             nLabels += 1;
             //writeln("..new label %n".format(fields[2]));
           }
           dataDom = {ldom.dim(1), 1..nLabels};
           data[ldom.last, fields[2]:int] = 1;
         }
         nLabelValues = nLabels;
       }
    }

    proc fromMatrix(y:[]) {
      writeln(y.domain.first);
      dataDom = {1..#y.shape[1], 1..#y.shape[2]};
      ref tmpD = data.reindex(y.domain);
      for ij in y.domain {
        tmpD[ij] = y[ij];
      }
      nLabelValues = y.shape[2];
    }

  }

  /*
   Does the pairwise cosine distance between rows of X.
   Dimensions must be conformable
   */
  proc cosineDistance(X:[?Xdom], denseOutput=true) {
    // TODO
    if !denseOutput then halt('denseOutput=false not yet supported');

    var cosDistDom: domain(2) = {Xdom.dim(1), Xdom.dim(1)},
        cosDist: [cosDistDom] real;

    // TODO: verbose output
    //writeln(" Got V: ", V.shape);
    //writeln(" cosDistDom.dims(1) ", cosDistDom.dims());

    // Pre-compute repeated cosim's
    var Xii: [Xdom.dim(1)] real;
    [i in Xdom.dim(1)] Xii[i] = dot(X[i,..], X[i,..]);

    //forall i in Xdom.dim(1) {
    forall i in Xdom.dim(1).first..Xdom.dim(1).last {
      const x1 = Xii[i];
      //for j in i+1..Xdom.dim(1).size {
      for j in i+1..Xdom.dim(1).last {
        // Do cosim
        const x2 = Xii[j];
        const c = 1 - dot(X[i,..], X[j,..]) / (x1 * x2);
        cosDist[i,j] = c;
        cosDist[j,i] = c;
      }
    }
    return cosDist;
  }

  /*
   Does the pairwise cosine distance between rows of X and rows of Y.
   Dimensions must be conformable
   */
  proc cosineDistance(X:[?Xdom], Y:[?Ydom], denseOutput=true) {
    // TODO
    if !denseOutput then halt('denseOutput=false not yet supported');

    if X.shape[2] != Y.shape[2] {
      halt(" dimension mismatch: X = (%n,%n)  Y = (%n,%n)".format(X.shape[1], X.shape[2], Y.shape[1], Y.shape[2]));
    }

    var cosDistDom: domain(2) = {Xdom.dim(1), Ydom.dim(1)},
        cosDist: [cosDistDom] real;

    // TODO: verbose output
    //writeln(" Got V: ", V.shape);
    //writeln(" cosDistDom.dims(1) ", cosDistDom.dims());

    // Pre-compute norms
    var Xii: [Xdom.dim(1)] real;
    var Yii: [Ydom.dim(1)] real;
    [i in Xdom.dim(1)] Xii[i] = dot(X[i,..], X[i,..]);
    [i in Ydom.dim(1)] Yii[i] = dot(Y[i,..], Y[i,..]);

    //forall i in Xdom.dim(1) {
    forall i in Xdom.dim(1).first..Xdom.dim(1).last {
      const x2 = Xii[i];
      //for j in i+1..Xdom.dim(1).size {
      // Cannot take advantage of symmetry, must walk the whole thing :(
      for j in Ydom.dim(1).first..Ydom.dim(1).last {
        // Do cosim
        const y2 = Yii[j];
        const c = 1 - dot(X[i,..], Y[j,..]) / (y2 * x2);
        cosDist[i,j] = c;
      }
    }
    return cosDist;
  }

  /*
   */
  proc subSampleLabels(L: LabelMatrix, sampleSize: int
      , replacementMethod: labelReplacementType = labelReplacementType.none) {
    var M = new LabelMatrix();
    M.ldom = L.ldom;
    M.dataDom = L.dataDom;
    [ij in L.dataDom] M.data[ij] = L.data[ij];
    var ids = [i in M.ldom] i;
    shuffle(ids);
    for i in sampleSize+1..ids.size{
      if replacementMethod ==  labelReplacementType.none {
        M.data[ids[i],..] = 0;
      } else if replacementMethod == labelReplacementType.inverseDegree {
        M.data[ids[i],..] = 1.0 / L.nLabelValues;
      }
      M.trainingLabelDom += ids[i];
    }
    return M;
  }

  proc argmax1d(x:[]) {
    var idx: int = 1,
        currentMax: real = x[1];
    for i in x.domain {
      if x[i] > currentMax {
        currentMax = x[i];
        idx = i;
      }
    }
    return idx;
  }

  /*
   axis = 0: argmax over whole object array (default)
          1: argmax for every row
          2: argmax for every column

   returns: tuple.  In the case of axis=0 this is the (i,j) coordinate of the max.
   */

  proc argmax(x: [], axis:int = 0 ) {
    //writeln(x.domain);
    //writeln(x.shape.size);
    var idom: domain(1) = {1..1};
    var idx: [idom] int;
    if x.shape.size == 1 {
      return argmax1d(x);
    } else if x.shape.size == 2 && axis==1 {
      idom = {1..#x.shape[1]};
      for i in x.domain.dim(1) {
        var y: [x.domain.dim(1)] real = x[i,..];
        idx[i] = argmax1d(y);
      }
      //writeln(idx);
      return idx;
    } else if  x.shape.size == 2 && axis==2 {
      idom = {1..#x.shape[2]};
      for j in x.domain.dim(2) {
        var y: [x.domain.dim(2)] real = x[..,j];
        idx[j] = argmax1d(y);
      }
      //writeln(idx);
      return idx;
    } else if x.shape.size == 2 && axis==0 {
      idom = {1..2};
      idx = (0,0);
      var currentMax: real = x[1,1];
      for (i,j) in x.domain {
        if x[i,j] > currentMax {
          idx = (i,j);
          currentMax = x[i,j];
        }
      }
      return idx;
    } else {
      halt("cannot resolve input dimension!");
    }
  }

  proc xlog2x(x: real) {
    if x > 0 {
      return x * log2(x);
    } else {
      return 0;
    }
  }
}


Added a _cast implementation so that the expression (x:string) produces the same string as write(x).

Did so by invoking x.writeThis on a StringClass instance.

This ensures that casting a range to string generates a bounded-sized string,
rather than a string showing the range's represented sequence
(as it was before).

Also provided a default expression for StringClass's field,
for convenience.

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

extern proc chpl_cstdin(): _file;
extern proc chpl_cstdout(): _file;
extern proc chpl_cstderr(): _file;
extern proc chpl_cerrno(): string;
extern proc chpl_cnullfile(): _file;
extern proc chpl_fopen(filename: string, modestring: string): _file;
extern proc chpl_fclose(file: _file): int;
extern proc chpl_fflush(file: _file): int;
extern proc chpl_fprintf(file: _file, s: string): int;
extern proc chpl_format(fmt: string, x): string;

// class file
//
//  chapel-level implementations of read, write, writeln
//  chapel-level implementations of assert, halt

enum FileAccessMode { read, write };

//
// functions on _file primitive type, the C file pointer type
//
pragma "inline" proc =(a: _file, b: _file) return b;
pragma "inline" proc ==(a: _file, b: _file) return __primitive("==", a, b);
pragma "inline" proc !=(a: _file, b: _file) return __primitive("!=", a, b);

pragma "inline" proc _readLitChar(fp: _file, val: string, ignoreWhiteSpace: bool)
  return __primitive("_fscan_literal", fp, val, ignoreWhiteSpace);

const stdin  = new file("stdin", FileAccessMode.read, "/dev", chpl_cstdin());
const stdout = new file("stdout", FileAccessMode.write, "/dev", chpl_cstdout());
const stderr = new file("stderr", FileAccessMode.write, "/dev", chpl_cstderr());

class file: Writer {
  var filename : string = "";
  var mode : FileAccessMode = FileAccessMode.read;
  var path : string = ".";
  var _fp : _file;
  var _lock : sync uint(64);    // for serializing output

  proc open() {
    on this {
      if this == stdin || this == stdout || this == stderr then
        halt("***Error: It is not necessary to open \"", filename, "\"***");

      var fullFilename = path + "/" + filename;

      var modestring: string;
      select mode {
        when FileAccessMode.read  do modestring = "r";
        when FileAccessMode.write do modestring = "w";
      }
      _fp = chpl_fopen(fullFilename, modestring);

      if _fp == chpl_cnullfile() {
        const err = chpl_cerrno();
        halt("***Error: Unable to open \"", fullFilename, "\": ", err, "***");
      }
    }
  }

  proc _checkFileStateChangeLegality(state) {
    if (isOpen) {
      halt("Cannot change ", state, " of file ", path, "/", filename,
           " while it is open");
    }
  }

  proc filename var : string {
    if setter then
      _checkFileStateChangeLegality("filename");
    return filename;
  }

  proc path var : string {
    if setter then
      _checkFileStateChangeLegality("path");
    return path;
  }

  proc mode var {
    if setter then
      _checkFileStateChangeLegality("mode");
    return mode;
  }

  proc isOpen: bool {
    var openStatus: bool = false;
    if (_fp != chpl_cnullfile()) {
      openStatus = true;
    }
    return openStatus;
  }

  proc close() {
    on this {
      if (this == stdin || this == stdout || this == stderr) {
        halt("***Error: You may not close \"", filename, "\"***");
      }
      if (_fp == chpl_cnullfile()) {
        var fullFilename = path + "/" + filename;
        halt("***Error: Trying to close \"", fullFilename,
             "\" which isn't open***");
      }
      var returnVal: int = chpl_fclose(_fp);
      if (returnVal < 0) {
        var fullFilename = path + "/" + filename;
        const err = chpl_cerrno();
        halt("***Error: The close of \"", fullFilename, "\" failed: ", err,
             "***");
      }
      _fp = chpl_cnullfile();
    }
  }
}

proc file.writeThis(f: Writer) {
  f.write("(filename = ",this.filename);
  f.write(", path = ",this.path);
  f.write(", mode = ",this.mode);
  f.write(")");
}

proc file.flush() {
  on this do chpl_fflush(_fp);
}

proc file.eof {
  extern proc feof(fp: _file): int;  // This should be a c_int not Chapel 'int'
  return (feof(_fp) != 0);
}

proc _checkOpen(f: file, isRead: bool) {
  if !f.isOpen {
    var fullFilename:string = f.path + "/" + f.filename;
    if isRead {
      halt("***Error: You must open \"", fullFilename,
           "\" before trying to read from it***");
    } else {
      halt("***Error: You must open \"", fullFilename,
           "\" before trying to write to it***");
    }
  }
}

proc file.readln() {
  on this {
    if !isOpen then
      _checkOpen(this, isRead=true);
    __primitive("_readToEndOfLine",_fp);
  }
}

proc file.readln(inout list ...?n) {
  read((...list));
  on this {
    __primitive("_readToEndOfLine",_fp);
  }
}

proc file.readln(type t) {
  var val: t;
  this.readln(val);
  return val;
}

proc file.read(inout first, inout rest ...?n) {
  read(first);
  for param i in 1..n do
    read(rest(i));
}

proc file.read(inout val: int) {
  if !isOpen then
    _checkOpen(this, isRead=true);
  var x: int;
  on this {
    x = __primitive("_fscan_int32", _fp);
  }
  val = x;
}

proc file.read(inout val: uint) {
  if !isOpen then
    _checkOpen(this, isRead=true);
  var x: uint;
  on this {
    x = __primitive("_fscan_uint32", _fp);
  }
  val = x;
}

proc file.read(inout val: real) {
  if !isOpen then
    _checkOpen(this, isRead=true);
  var x: real;
  on this {
    x = __primitive("_fscan_real64", _fp);
  }
  val = x;
}

proc file.read(inout val: complex) {
  var realPart: real;
  var imagPart: real;
  var imagI: string;
  var matchingCharWasRead: int;
  var isNeg: bool;

  read(realPart);
  on this {
    matchingCharWasRead = _readLitChar(_fp, "+", true);
  }
  if (matchingCharWasRead != 1) {
    on this {
      matchingCharWasRead = _readLitChar(_fp, "-", true);
    }
    if (matchingCharWasRead != 1) {
      halt("***Error: Incorrect format for complex numbers***");
    }
    isNeg = true;
  }

  read(imagPart);
  on this {
    matchingCharWasRead = _readLitChar(_fp, "i", false);
  }
  if (matchingCharWasRead != 1) {
    halt("***Error: Incorrect format for complex numbers***");
  }

  val.re = realPart;
  if (isNeg) {
    val.im = -imagPart;
  } else {
    val.im = imagPart;
  }
}

proc file.read(inout val: string) {
  if !isOpen then
    _checkOpen(this, isRead=true);
  var x: string;
  on this {
    x = __primitive("_fscan_string", _fp);
  }
  val = x;
}

proc file.read(inout val: bool) {
  var s: string;
  this.read(s);
  if (s == "true") {
    val = true;
  } else if (s == "false") {
    val = false;
  } else {
    halt("read of bool value that is neither true nor false");
  }
}

proc file.read(type t) {
  var val: t;
  this.read(val);
  return val;
}

proc string.writeThis(f: Writer) {
  f.writeIt(this);
}

proc numeric.writeThis(f: Writer) {
  f.writeIt(this:string);
}

proc enumerated.writeThis(f: Writer) {
  f.writeIt(this:string);
}

proc bool.writeThis(f: Writer) {
  f.writeIt(this:string);
}

proc chpl_taskID_t.writeThis(f: Writer) {
  var tmp : uint(64) = this : uint(64);
  f.writeIt(tmp : string);
}

proc file.writeIt(s: string) {
  if !isOpen then
    _checkOpen(this, isRead = false);
  if mode != FileAccessMode.write then
    halt("***Error: ", path, "/", filename, " not open for writing***");
  var status = chpl_fprintf(_fp, s);
  if status < 0 {
    const err = chpl_cerrno();
    halt("***Error: Write failed: ", err, "***");
  }
}

class StringClass: Writer {
  var s: string = "";
  proc writeIt(s: string) { this.s += s; }
}

pragma "ref this" pragma "dont disable remote value forwarding"
proc string.write(args ...?n) {
  var sc = new StringClass(this);
  sc.write((...args));
  this = sc.s;
  delete sc;
}

// Convert 'x' to a string just the way it would be written out.
// Includes Writer.write, with modifications (for simplicity; to avoid 'on').
proc _cast(type t, x) where t == string {
  proc isNilObject(o: object) return o == nil;
  proc isNilObject(o) param return false;
  const w = new StringClass();
  if isNilObject(x) then "nil".writeThis(w);
  else                   x.writeThis(w);
  const result = w.s;
  delete w;
  return result;
}

proc file.lockWrite() {
  var me: uint(64) = __primitive("task_id") : uint(64);
  if _lock.isFull then
    if _lock.readXX() == me then
      return false;
  _lock = me;
  return true;
}

proc file.unlockWrite() {
  _lock.reset();
}

class Writer {
  proc writeIt(s: string) { }
  proc lockWrite() return false;
  proc unlockWrite() { }
  proc write(args ...?n) {
    proc isNilObject(val) {
      proc helper(o: object) return o == nil;
      proc helper(o)         return false;
      return helper(val);
    }

    on this {
      var need_release: bool;
      need_release = lockWrite();
      for param i in 1..n do
        if isNilObject(args(i)) then
          "nil".writeThis(this);
        else
          args(i).writeThis(this);
      if need_release then
        unlockWrite();
    }
  }
  proc writeln(args ...?n) {
    write((...args), "\n");
  }
  proc writeln() {
    write("\n");
  }
}

proc write(args ...?n) {
  stdout.write((...args));
  stdout.flush();
}

proc writeln(args ...?n) {
  stdout.writeln((...args));
  stdout.flush();
}

proc writeln() {
  stdout.writeln();
  stdout.flush();
}

proc read(inout args ...?n) {
  stdin.read((...args));
}

proc readln(inout args ...?n) {
  stdin.readln((...args));
}

proc readln() {
  stdin.readln();
}

proc readln(type t) {
  return stdin.readln(t);
}

proc read(type t)
  return stdin.read(t);

proc file.readln(type t ...?numTypes) where numTypes > 1 {
  var tupleVal: t;
  for param i in 1..numTypes-1 do
    tupleVal(i) = this.read(t(i));
  tupleVal(numTypes) = this.readln(t(numTypes));
  return tupleVal;
}

proc file.read(type t ...?numTypes) where numTypes > 1 {
  var tupleVal: t;
  for param i in 1..numTypes do
    tupleVal(i) = this.read(t(i));
  return tupleVal;
}

proc readln(type t ...?numTypes) where numTypes > 1
  return stdin.readln((...t));

proc read(type t ...?numTypes) where numTypes > 1
  return stdin.read((...t));

proc _tuple2string(t) {
  var s: string;
  for param i in 1..t.size do
    s.write(t(i));
  return s;
}

proc assert(test: bool) {
  if !test then
    __primitive("chpl_error", "assert failed");
}

proc assert(test: bool, args ...?numArgs) {
  if !test then
    __primitive("chpl_error", "assert failed - "+_tuple2string(args));
}

proc halt() {
  __primitive("chpl_error", "halt reached");
}

proc halt(args ...?numArgs) {
  __primitive("chpl_error", "halt reached - "+_tuple2string(args));
}

proc _debugWrite(args...?n) {
  proc getString(a: ?t) {
    if t == bool(8) || t == bool(16) || t == bool(32) || t == bool(64) ||
       t == int(8) || t == int(16) || t == int(32) || t == int(64) ||
       t == uint(8) || t == uint(16) || t == uint(32) || t == uint(64) ||
       t == real(32) || t == real(64) || t == imag(32) || t == imag(64) ||
       t == complex(64) || t == complex(128) ||
       t == bool || t == string || _isEnumeratedType(t) then
      return a:string;
    else
      compilerError("Cannot call _debugWrite on value of type ",
                    typeToString(t));
  }
  for param i in 1..n {
    var status = chpl_fprintf(chpl_cstdout(), getString(args(i)));
    if status < 0 {
      const err = chpl_cerrno();
      halt("_debugWrite failed with status ", err);
    }
  }
  chpl_fflush(chpl_cstdout());
}

proc _debugWriteln(args...?n) {
  _debugWrite((...args), "\n");
}

proc _debugWriteln() {
  _debugWrite("\n");
}

proc _ddata.writeThis(f: Writer) {
  halt("cannot write the _ddata class");
}

proc format(fmt: string, x:?t) where _isIntegralType(t) || _isFloatType(t) {
  if fmt.substring(1) == "#" {
    var fmt2 = _getoutputformat(fmt);
    if _isImagType(t) then
      return (chpl_format(fmt2, _i2r(x))+"i");
    else
      return chpl_format(fmt2, x:real);
  } else
    return chpl_format(fmt, x);
}

proc format(fmt: string, x:?t) where _isComplexType(t) {
  if fmt.substring(1) == "#" {
    var fmt2 = _getoutputformat(fmt);
    return (chpl_format(fmt2, x.re)+" + "+ chpl_format(fmt2, x.im)+"i");
  } else
    return chpl_format(fmt, x);
}

proc format(fmt: string, x: ?t) {
  return chpl_format(fmt, x);
}

proc _getoutputformat(s: string):string {
  var sn = s.length;
  var afterdot = false;
  var dplaces = 0;
  for i in 1..sn {
    if ((s.substring(i) == '#') & afterdot) then dplaces += 1;
    if (s.substring(i) == '.') then afterdot=true;
  }

  return("%" + sn + "." + dplaces + "f");
}

//
// When this flag is used during compilation, calls to chpl__testPar
// will output a message to indicate that a portion of the code has been
// parallelized.
//
config param chpl__testParFlag = false;
var chpl__testParOn = false;

proc chpl__testParStart() {
  chpl__testParOn = true;
}

proc chpl__testParStop() {
  chpl__testParOn = false;
}

pragma "inline"
proc chpl__testPar(args...) where chpl__testParFlag == false { }

proc chpl__testPar(args...) where chpl__testParFlag == true {
  if chpl__testParFlag && chpl__testParOn {
    const file : string = __primitive("_get_user_file");
    const line : int = __primitive("_get_user_line");
    writeln("CHPL TEST PAR (", file, ":", line, "): ", (...args));
  }
}

extern proc chpl_cstdin(): _file;
extern proc chpl_cstdout(): _file;
extern proc chpl_cstderr(): _file;
extern proc chpl_cerrno(): string;
extern proc chpl_cnullfile(): _file;
extern proc chpl_fopen(filename: string, modestring: string): _file;
extern proc chpl_fclose(file: _file): int;
extern proc chpl_fflush(file: _file): int;
extern proc chpl_fprintf(file: _file, s: string): int;
extern proc chpl_format(fmt: string, x): string;

// class file
//
//  chapel-level implementations of read, write, writeln
//  chapel-level implementations of assert, halt

enum FileAccessMode { read, write };

//
// functions on _file primitive type, the C file pointer type
//
pragma "inline" proc =(a: _file, b: _file) return b;
pragma "inline" proc ==(a: _file, b: _file) return __primitive("==", a, b);
pragma "inline" proc !=(a: _file, b: _file) return __primitive("!=", a, b);

pragma "inline" proc _readLitChar(fp: _file, val: string, ignoreWhiteSpace: bool)
  return __primitive("_fscan_literal", fp, val, ignoreWhiteSpace);

const stdin  = new file("stdin", FileAccessMode.read, "/dev", chpl_cstdin());
const stdout = new file("stdout", FileAccessMode.write, "/dev", chpl_cstdout());
const stderr = new file("stderr", FileAccessMode.write, "/dev", chpl_cstderr());

class file: Writer {
  var filename : string = "";
  var mode : FileAccessMode = FileAccessMode.read;
  var path : string = ".";
  var _fp : _file;
  var _lock : sync uint(64);    // for serializing output

  proc open() {
    on this {
      if this == stdin || this == stdout || this == stderr then
        halt("***Error: It is not necessary to open \"", filename, "\"***");

      var fullFilename = path + "/" + filename;

      var modestring: string;
      select mode {
        when FileAccessMode.read  do modestring = "r";
        when FileAccessMode.write do modestring = "w";
      }
      _fp = chpl_fopen(fullFilename, modestring);

      if _fp == chpl_cnullfile() {
        const err = chpl_cerrno();
        halt("***Error: Unable to open \"", fullFilename, "\": ", err, "***");
      }
    }
  }

  proc _checkFileStateChangeLegality(state) {
    if (isOpen) {
      halt("Cannot change ", state, " of file ", path, "/", filename,
           " while it is open");
    }
  }

  proc filename var : string {
    if setter then
      _checkFileStateChangeLegality("filename");
    return filename;
  }

  proc path var : string {
    if setter then
      _checkFileStateChangeLegality("path");
    return path;
  }

  proc mode var {
    if setter then
      _checkFileStateChangeLegality("mode");
    return mode;
  }

  proc isOpen: bool {
    var openStatus: bool = false;
    if (_fp != chpl_cnullfile()) {
      openStatus = true;
    }
    return openStatus;
  }

  proc close() {
    on this {
      if (this == stdin || this == stdout || this == stderr) {
        halt("***Error: You may not close \"", filename, "\"***");
      }
      if (_fp == chpl_cnullfile()) {
        var fullFilename = path + "/" + filename;
        halt("***Error: Trying to close \"", fullFilename,
             "\" which isn't open***");
      }
      var returnVal: int = chpl_fclose(_fp);
      if (returnVal < 0) {
        var fullFilename = path + "/" + filename;
        const err = chpl_cerrno();
        halt("***Error: The close of \"", fullFilename, "\" failed: ", err,
             "***");
      }
      _fp = chpl_cnullfile();
    }
  }
}

proc file.writeThis(f: Writer) {
  f.write("(filename = ",this.filename);
  f.write(", path = ",this.path);
  f.write(", mode = ",this.mode);
  f.write(")");
}

proc file.flush() {
  on this do chpl_fflush(_fp);
}

proc file.eof {
  extern proc feof(fp: _file): int;  // This should be a c_int not Chapel 'int'
  return (feof(_fp) != 0);
}

proc _checkOpen(f: file, isRead: bool) {
  if !f.isOpen {
    var fullFilename:string = f.path + "/" + f.filename;
    if isRead {
      halt("***Error: You must open \"", fullFilename,
           "\" before trying to read from it***");
    } else {
      halt("***Error: You must open \"", fullFilename,
           "\" before trying to write to it***");
    }
  }
}

proc file.readln() {
  on this {
    if !isOpen then
      _checkOpen(this, isRead=true);
    __primitive("_readToEndOfLine",_fp);
  }
}

proc file.readln(inout list ...?n) {
  read((...list));
  on this {
    __primitive("_readToEndOfLine",_fp);
  }
}

proc file.readln(type t) {
  var val: t;
  this.readln(val);
  return val;
}

proc file.read(inout first, inout rest ...?n) {
  read(first);
  for param i in 1..n do
    read(rest(i));
}

proc file.read(inout val: int) {
  if !isOpen then
    _checkOpen(this, isRead=true);
  var x: int;
  on this {
    x = __primitive("_fscan_int32", _fp);
  }
  val = x;
}

proc file.read(inout val: uint) {
  if !isOpen then
    _checkOpen(this, isRead=true);
  var x: uint;
  on this {
    x = __primitive("_fscan_uint32", _fp);
  }
  val = x;
}

proc file.read(inout val: real) {
  if !isOpen then
    _checkOpen(this, isRead=true);
  var x: real;
  on this {
    x = __primitive("_fscan_real64", _fp);
  }
  val = x;
}

proc file.read(inout val: complex) {
  var realPart: real;
  var imagPart: real;
  var imagI: string;
  var matchingCharWasRead: int;
  var isNeg: bool;

  read(realPart);
  on this {
    matchingCharWasRead = _readLitChar(_fp, "+", true);
  }
  if (matchingCharWasRead != 1) {
    on this {
      matchingCharWasRead = _readLitChar(_fp, "-", true);
    }
    if (matchingCharWasRead != 1) {
      halt("***Error: Incorrect format for complex numbers***");
    }
    isNeg = true;
  }

  read(imagPart);
  on this {
    matchingCharWasRead = _readLitChar(_fp, "i", false);
  }
  if (matchingCharWasRead != 1) {
    halt("***Error: Incorrect format for complex numbers***");
  }

  val.re = realPart;
  if (isNeg) {
    val.im = -imagPart;
  } else {
    val.im = imagPart;
  }
}

proc file.read(inout val: string) {
  if !isOpen then
    _checkOpen(this, isRead=true);
  var x: string;
  on this {
    x = __primitive("_fscan_string", _fp);
  }
  val = x;
}

proc file.read(inout val: bool) {
  var s: string;
  this.read(s);
  if (s == "true") {
    val = true;
  } else if (s == "false") {
    val = false;
  } else {
    halt("read of bool value that is neither true nor false");
  }
}

proc file.read(type t) {
  var val: t;
  this.read(val);
  return val;
}

proc string.writeThis(f: Writer) {
  f.writeIt(this);
}

proc numeric.writeThis(f: Writer) {
  f.writeIt(this:string);
}

proc enumerated.writeThis(f: Writer) {
  f.writeIt(this:string);
}

proc bool.writeThis(f: Writer) {
  f.writeIt(this:string);
}

proc chpl_taskID_t.writeThis(f: Writer) {
  var tmp : uint(64) = this : uint(64);
  f.writeIt(tmp : string);
}

proc file.writeIt(s: string) {
  if !isOpen then
    _checkOpen(this, isRead = false);
  if mode != FileAccessMode.write then
    halt("***Error: ", path, "/", filename, " not open for writing***");
  var status = chpl_fprintf(_fp, s);
  if status < 0 {
    const err = chpl_cerrno();
    halt("***Error: Write failed: ", err, "***");
  }
}

class StringClass: Writer {
  var s: string;
  proc writeIt(s: string) { this.s += s; }
}

pragma "ref this" pragma "dont disable remote value forwarding"
proc string.write(args ...?n) {
  var sc = new StringClass(this);
  sc.write((...args));
  this = sc.s;
  delete sc;
}

proc file.lockWrite() {
  var me: uint(64) = __primitive("task_id") : uint(64);
  if _lock.isFull then
    if _lock.readXX() == me then
      return false;
  _lock = me;
  return true;
}

proc file.unlockWrite() {
  _lock.reset();
}

class Writer {
  proc writeIt(s: string) { }
  proc lockWrite() return false;
  proc unlockWrite() { }
  proc write(args ...?n) {
    proc isNilObject(val) {
      proc helper(o: object) return o == nil;
      proc helper(o)         return false;
      return helper(val);
    }

    on this {
      var need_release: bool;
      need_release = lockWrite();
      for param i in 1..n do
        if isNilObject(args(i)) then
          "nil".writeThis(this);
        else
          args(i).writeThis(this);
      if need_release then
        unlockWrite();
    }
  }
  proc writeln(args ...?n) {
    write((...args), "\n");
  }
  proc writeln() {
    write("\n");
  }
}

proc write(args ...?n) {
  stdout.write((...args));
  stdout.flush();
}

proc writeln(args ...?n) {
  stdout.writeln((...args));
  stdout.flush();
}

proc writeln() {
  stdout.writeln();
  stdout.flush();
}

proc read(inout args ...?n) {
  stdin.read((...args));
}

proc readln(inout args ...?n) {
  stdin.readln((...args));
}

proc readln() {
  stdin.readln();
}

proc readln(type t) {
  return stdin.readln(t);
}

proc read(type t)
  return stdin.read(t);

proc file.readln(type t ...?numTypes) where numTypes > 1 {
  var tupleVal: t;
  for param i in 1..numTypes-1 do
    tupleVal(i) = this.read(t(i));
  tupleVal(numTypes) = this.readln(t(numTypes));
  return tupleVal;
}

proc file.read(type t ...?numTypes) where numTypes > 1 {
  var tupleVal: t;
  for param i in 1..numTypes do
    tupleVal(i) = this.read(t(i));
  return tupleVal;
}

proc readln(type t ...?numTypes) where numTypes > 1
  return stdin.readln((...t));

proc read(type t ...?numTypes) where numTypes > 1
  return stdin.read((...t));

proc _tuple2string(t) {
  var s: string;
  for param i in 1..t.size do
    s.write(t(i));
  return s;
}

proc assert(test: bool) {
  if !test then
    __primitive("chpl_error", "assert failed");
}

proc assert(test: bool, args ...?numArgs) {
  if !test then
    __primitive("chpl_error", "assert failed - "+_tuple2string(args));
}

proc halt() {
  __primitive("chpl_error", "halt reached");
}

proc halt(args ...?numArgs) {
  __primitive("chpl_error", "halt reached - "+_tuple2string(args));
}

proc _debugWrite(args...?n) {
  proc getString(a: ?t) {
    if t == bool(8) || t == bool(16) || t == bool(32) || t == bool(64) ||
       t == int(8) || t == int(16) || t == int(32) || t == int(64) ||
       t == uint(8) || t == uint(16) || t == uint(32) || t == uint(64) ||
       t == real(32) || t == real(64) || t == imag(32) || t == imag(64) ||
       t == complex(64) || t == complex(128) ||
       t == bool || t == string || _isEnumeratedType(t) then
      return a:string;
    else
      compilerError("Cannot call _debugWrite on value of type ",
                    typeToString(t));
  }
  for param i in 1..n {
    var status = chpl_fprintf(chpl_cstdout(), getString(args(i)));
    if status < 0 {
      const err = chpl_cerrno();
      halt("_debugWrite failed with status ", err);
    }
  }
  chpl_fflush(chpl_cstdout());
}

proc _debugWriteln(args...?n) {
  _debugWrite((...args), "\n");
}

proc _debugWriteln() {
  _debugWrite("\n");
}

proc _ddata.writeThis(f: Writer) {
  halt("cannot write the _ddata class");
}

proc format(fmt: string, x:?t) where _isIntegralType(t) || _isFloatType(t) {
  if fmt.substring(1) == "#" {
    var fmt2 = _getoutputformat(fmt);
    if _isImagType(t) then
      return (chpl_format(fmt2, _i2r(x))+"i");
    else
      return chpl_format(fmt2, x:real);
  } else
    return chpl_format(fmt, x);
}

proc format(fmt: string, x:?t) where _isComplexType(t) {
  if fmt.substring(1) == "#" {
    var fmt2 = _getoutputformat(fmt);
    return (chpl_format(fmt2, x.re)+" + "+ chpl_format(fmt2, x.im)+"i");
  } else
    return chpl_format(fmt, x);
}

proc format(fmt: string, x: ?t) {
  return chpl_format(fmt, x);
}

proc _getoutputformat(s: string):string {
  var sn = s.length;
  var afterdot = false;
  var dplaces = 0;
  for i in 1..sn {
    if ((s.substring(i) == '#') & afterdot) then dplaces += 1;
    if (s.substring(i) == '.') then afterdot=true;
  }

  return("%" + sn + "." + dplaces + "f");
}

//
// When this flag is used during compilation, calls to chpl__testPar
// will output a message to indicate that a portion of the code has been
// parallelized.
//
config param chpl__testParFlag = false;
var chpl__testParOn = false;

proc chpl__testParStart() {
  chpl__testParOn = true;
}

proc chpl__testParStop() {
  chpl__testParOn = false;
}

pragma "inline"
proc chpl__testPar(args...) where chpl__testParFlag == false { }

proc chpl__testPar(args...) where chpl__testParFlag == true {
  if chpl__testParFlag && chpl__testParOn {
    const file : string = __primitive("_get_user_file");
    const line : int = __primitive("_get_user_line");
    writeln("CHPL TEST PAR (", file, ":", line, "): ", (...args));
  }
}


Make refcount debugging halts print out the offending ref count.

Also, allow up to 10000 refs to a given distribution.

/*
 * 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.
 */

module ChapelDistribution {

  use List;

  extern proc chpl_task_yield();

  //
  // Abstract distribution class
  //
  pragma "base dist"
  class BaseDist {
    // The common case seems to be local access to this class, so we
    // will use explicit processor atomics, even when network
    // atomics are available
    var _distCnt: atomic_refcnt; // distribution reference count
    var _doms: list(BaseDom);   // domains declared over this distribution
    var _domsLock: atomicflag;  //   and lock for concurrent access

    pragma "dont disable remote value forwarding"
    proc destroyDist(): int {
      compilerAssert(!noRefCount);
      return decRefCount();
    }

    inline proc remove_dom(x) {
      on this {
        _lock_doms();
        _doms.remove(x);
        _unlock_doms();
      }
    }

    inline proc add_dom(x) {
      on this {
        _lock_doms();
        _doms.append(x);
        _unlock_doms();
      }
    }

    inline proc _lock_doms() {
      // WARNING: If you are calling this function directly from
      // a remote locale, you should consider wrapping the call in
      // an on clause to avoid excessive remote forks due to the
      // testAndSet()
      while (_domsLock.testAndSet()) do chpl_task_yield();
    }

    inline proc _unlock_doms() {
      _domsLock.clear();
    }

    proc dsiNewRectangularDom(param rank: int, type idxType, param stridable: bool) {
      compilerError("rectangular domains not supported by this distribution");
    }

    proc dsiNewAssociativeDom(type idxType, param parSafe: bool) {
      compilerError("associative domains not supported by this distribution");
    }

    proc dsiNewAssociativeDom(type idxType, param parSafe: bool)
    where isEnumType(idxType) {
      compilerError("enumerated domains not supported by this distribution");
    }

    proc dsiNewOpaqueDom(type idxType, param parSafe: bool) {
      compilerError("opaque domains not supported by this distribution");
    }

    proc dsiNewSparseDom(param rank: int, type idxType, dom: domain) {
      compilerError("sparse domains not supported by this distribution");
    }

    inline proc incRefCount(cnt=1) {
      compilerAssert(!noRefCount);
      if debugDistRefCount > 0 {
        const cnt = _distCnt.read();
        if debugDistRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- INC _distCnt (%016lx) was %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
          halt("_distCnt ", cnt, " is bogus!");
      }
      _distCnt.inc(cnt);
    }

    inline proc decRefCount() {
      compilerAssert(!noRefCount);
      const cnt = _distCnt.dec();
      if debugDistRefCount > 0 {
        if debugDistRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- DEC _distCnt (%016lx) now %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
          halt("_distCnt ", cnt, " is bogus!");
        // Poison the distCount, so an attempt to move it away from zero a
        // second time will fail
        if cnt == 0 then _distCnt.dec();
      }
      return cnt;
    }

    proc dsiSupportsPrivatization() param return false;
    proc dsiRequiresPrivatization() param return false;

    proc dsiDestroyDistClass() { }

    proc dsiDisplayRepresentation() { }
  }

  //
  // Abstract domain classes
  //
  pragma "base domain"
  class BaseDom {
    // The common case seems to be local access to this class, so we
    // will use explicit processor atomics, even when network
    // atomics are available
    var _domCnt: atomic_refcnt; // domain reference count
    var _arrs: list(BaseArr);  // arrays declared over this domain
    var _arrsLock: atomicflag; //   and lock for concurrent access

    proc dsiMyDist(): BaseDist {
      halt("internal error: dsiMyDist is not implemented");
      return nil;
    }

    pragma "dont disable remote value forwarding"
    proc destroyDom(): int {
      compilerAssert(!noRefCount);
      return decRefCount();
    }

    inline proc remove_arr(x) {
      on this {
        _lock_arrs();
        _arrs.remove(x);
        _unlock_arrs();
      }
    }

    inline proc add_arr(x) {
      on this {
        _lock_arrs();
        _arrs.append(x);
        _unlock_arrs();
      }
    }

    inline proc _lock_arrs() {
      // WARNING: If you are calling this function directly from
      // a remote locale, you should consider wrapping the call in
      // an on clause to avoid excessive remote forks due to the
      // testAndSet()
      while (_arrsLock.testAndSet()) do chpl_task_yield();
    }

    inline proc _unlock_arrs() {
      _arrsLock.clear();
    }

    // used for associative domains/arrays
    proc _backupArrays() {
      for arr in _arrs do
        arr._backupArray();
    }

    proc _removeArrayBackups() {
      for arr in _arrs do
        arr._removeArrayBackup();
    }

    proc _preserveArrayElements(oldslot, newslot) {
      for arr in _arrs do
        arr._preserveArrayElement(oldslot, newslot);
    }

    inline proc incRefCount(cnt=1) {
      compilerAssert(!noRefCount);
      if debugDomRefCount > 0 {
        const cnt = _domCnt.read();
        if debugDomRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- INC _domCnt (%016lx) was %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
          halt("_domCnt ", cnt, " is bogus!");
      }
      _domCnt.inc(cnt);
    }

    inline proc decRefCount() {
      compilerAssert(!noRefCount);
      const cnt = _domCnt.dec(); //_domCnt.fetchSub(1)-1;
      if debugDomRefCount > 0 {
        if debugDomRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- DEC _domCnt (%016lx) now %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
          halt("_domCnt ", cnt, " is bogus!");
        // Poison the domCount, so an attempt to move it away from zero a
        // second time will fail
        if cnt == 0 then _domCnt.dec();
      }
      return cnt;
    }

    proc dsiSupportsPrivatization() param return false;
    proc dsiRequiresPrivatization() param return false;

    // false for default distribution so that we don't increment the
    // default distribution's reference count and add domains to the
    // default distribution's list of domains
    proc linksDistribution() param return true;

    // dynamically-dispatched counterpart of linksDistribution
    proc dsiLinksDistribution() return true;

    proc dsiDisplayRepresentation() { }
  }

  class BaseRectangularDom : BaseDom {
    proc dsiClear() {
      halt("clear not implemented for this distribution");
    }

    proc clearForIteratableAssign() {
      compilerError("Illegal assignment to a rectangular domain");
    }

    proc dsiAdd(x) {
      compilerError("Cannot add indices to a rectangular domain");
    }

    proc dsiRemove(x) {
      compilerError("Cannot remove indices from a rectangular domain");
    }
  }

  class BaseSparseDom : BaseDom {
    proc dsiClear() {
      halt("clear not implemented for this distribution");
    }

    proc clearForIteratableAssign() {
      dsiClear();
    }
  }

  class BaseAssociativeDom : BaseDom {
    proc dsiClear() {
      halt("clear not implemented for this distribution");
    }

    proc clearForIteratableAssign() {
      dsiClear();
    }
  }

  class BaseOpaqueDom : BaseDom {
    proc dsiClear() {
      halt("clear not implemented for this distribution");
    }

    proc clearForIteratableAssign() {
      dsiClear();
    }
  }

  //
  // Abstract array class
  //
  pragma "base array"
  class BaseArr {
    // The common case seems to be local access to this class, so we
    // will use explicit processor atomics, even when network
    // atomics are available
    var _arrCnt: atomic_refcnt; // array reference count
    var _arrAlias: BaseArr;    // reference to base array if an alias

    proc dsiStaticFastFollowCheck(type leadType) param return false;

    proc dsiGetBaseDom(): BaseDom {
      halt("internal error: dsiGetBaseDom is not implemented");
      return nil;
    }

    pragma "dont disable remote value forwarding"
    proc destroyArr(): int {
      compilerAssert(!noRefCount);
      var cnt = decRefCount();
      if cnt == 0 {
        if _arrAlias {
          on _arrAlias {
            var cnt = _arrAlias.destroyArr();
            if cnt == 0 then
              delete _arrAlias;
          }
        } else {
          dsiDestroyData();
        }
      }
      return cnt;
    }

    proc dsiDestroyData() { }

    proc dsiReallocate(d: domain) {
      halt("reallocating not supported for this array type");
    }

    proc dsiPostReallocate() {
    }

    // This method is unsatisfactory -- see bradc's commit entries of
    // 01/02/08 around 14:30 for details
    proc _purge( ind: int) {
      halt("purging not supported for this array type");
    }

    proc _resize( length: int, old_map) {
      halt("resizing not supported for this array type");
    }

    //
    // Ultimately, these routines should not appear here; instead, we'd
    // like to do a dynamic cast in the sparse array class(es) that call
    // these routines in order to call them directly and avoid the
    // dynamic dispatch and leaking of this name to the class.  In order
    // to do this we'd need to hoist eltType to the base class, which
    // would require better subclassing of generic classes.  A good
    // summer project for Jonathan?
    //
    proc sparseShiftArray(shiftrange, initrange) {
      halt("sparseGrowDomain not supported for non-sparse arrays");
    }

    proc sparseShiftArrayBack(shiftrange) {
      halt("sparseShiftArrayBack not supported for non-sparse arrays");
    }

    // methods for associative arrays
    proc clearEntry(idx, haveLock:bool = false) {
      halt("clearEntry() not supported for non-associative arrays");
    }

    proc _backupArray() {
      halt("_backupArray() not supported for non-associative arrays");
    }

    proc _removeArrayBackup() {
      halt("_removeArrayBackup() not supported for non-associative arrays");
    }

    proc _preserveArrayElement(oldslot, newslot) {
      halt("_preserveArrayElement() not supported for non-associative arrays");
    }

    inline proc incRefCount(cnt=1) {
      compilerAssert(!noRefCount);
      if debugArrRefCount > 0 {
        const cnt = _arrCnt.read();
        if debugArrRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- INC _arrCnt (%016lx) was %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
          halt("_arrCnt ", cnt, " is bogus!");
      }
      _arrCnt.inc(cnt);
    }

    inline proc decRefCount() {
      compilerAssert(!noRefCount);
      const cnt = _arrCnt.dec(); //_arrCnt.fetchSub(1)-1;
      if debugArrRefCount > 0 {
        if debugArrRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- DEC _arrCnt (%016lx) now %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
          halt("_arrCnt ", cnt, " is bogus!");
        // Poison the arrCount, so an attempt to move it away from zero a
        // second time will fail
        if cnt == 0 then _arrCnt.dec();
      }
      return cnt;
    }

    proc dsiSupportsAlignedFollower() param return false;

    proc dsiSupportsPrivatization() param return false;
    proc dsiRequiresPrivatization() param return false;

    proc dsiSupportsBulkTransfer() param return false;
    proc doiCanBulkTransfer() param return false;
    proc doiBulkTransfer(B){
      halt("This array type does not support bulk transfer.");
    }

    proc dsiDisplayRepresentation() { }
    proc isDefaultRectangular() param return false;
    proc dsiSupportsBulkTransferInterface() param return false;
    proc doiCanBulkTransferStride() param return false;
  }

}

/*
 * 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.
 */

module ChapelDistribution {

  use List;

  extern proc chpl_task_yield();

  //
  // Abstract distribution class
  //
  pragma "base dist"
  class BaseDist {
    // The common case seems to be local access to this class, so we
    // will use explicit processor atomics, even when network
    // atomics are available
    var _distCnt: atomic_refcnt; // distribution reference count
    var _doms: list(BaseDom);   // domains declared over this distribution
    var _domsLock: atomicflag;  //   and lock for concurrent access

    pragma "dont disable remote value forwarding"
    proc destroyDist(): int {
      compilerAssert(!noRefCount);
      return decRefCount();
    }

    inline proc remove_dom(x) {
      on this {
        _lock_doms();
        _doms.remove(x);
        _unlock_doms();
      }
    }

    inline proc add_dom(x) {
      on this {
        _lock_doms();
        _doms.append(x);
        _unlock_doms();
      }
    }

    inline proc _lock_doms() {
      // WARNING: If you are calling this function directly from
      // a remote locale, you should consider wrapping the call in
      // an on clause to avoid excessive remote forks due to the
      // testAndSet()
      while (_domsLock.testAndSet()) do chpl_task_yield();
    }

    inline proc _unlock_doms() {
      _domsLock.clear();
    }

    proc dsiNewRectangularDom(param rank: int, type idxType, param stridable: bool) {
      compilerError("rectangular domains not supported by this distribution");
    }

    proc dsiNewAssociativeDom(type idxType, param parSafe: bool) {
      compilerError("associative domains not supported by this distribution");
    }

    proc dsiNewAssociativeDom(type idxType, param parSafe: bool)
    where isEnumType(idxType) {
      compilerError("enumerated domains not supported by this distribution");
    }

    proc dsiNewOpaqueDom(type idxType, param parSafe: bool) {
      compilerError("opaque domains not supported by this distribution");
    }

    proc dsiNewSparseDom(param rank: int, type idxType, dom: domain) {
      compilerError("sparse domains not supported by this distribution");
    }

    inline proc incRefCount(cnt=1) {
      compilerAssert(!noRefCount);
      if debugDistRefCount > 0 {
        const cnt = _distCnt.read();
        if debugDistRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- INC _distCnt (%016lx) was %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 1000 then
            halt("_distCnt is bogus!");
      }
      _distCnt.inc(cnt);
    }

    inline proc decRefCount() {
      compilerAssert(!noRefCount);
      const cnt = _distCnt.dec();
      if debugDistRefCount > 0 {
        if debugDistRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- DEC _distCnt (%016lx) now %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 1000 then
            halt("_distCnt is bogus!");
        // Poison the distCount, so an attempt to move it away from zero a
        // second time will fail
        if cnt == 0 then _distCnt.dec();
      }
      return cnt;
    }

    proc dsiSupportsPrivatization() param return false;
    proc dsiRequiresPrivatization() param return false;

    proc dsiDestroyDistClass() { }

    proc dsiDisplayRepresentation() { }
  }

  //
  // Abstract domain classes
  //
  pragma "base domain"
  class BaseDom {
    // The common case seems to be local access to this class, so we
    // will use explicit processor atomics, even when network
    // atomics are available
    var _domCnt: atomic_refcnt; // domain reference count
    var _arrs: list(BaseArr);  // arrays declared over this domain
    var _arrsLock: atomicflag; //   and lock for concurrent access

    proc dsiMyDist(): BaseDist {
      halt("internal error: dsiMyDist is not implemented");
      return nil;
    }

    pragma "dont disable remote value forwarding"
    proc destroyDom(): int {
      compilerAssert(!noRefCount);
      return decRefCount();
    }

    inline proc remove_arr(x) {
      on this {
        _lock_arrs();
        _arrs.remove(x);
        _unlock_arrs();
      }
    }

    inline proc add_arr(x) {
      on this {
        _lock_arrs();
        _arrs.append(x);
        _unlock_arrs();
      }
    }

    inline proc _lock_arrs() {
      // WARNING: If you are calling this function directly from
      // a remote locale, you should consider wrapping the call in
      // an on clause to avoid excessive remote forks due to the
      // testAndSet()
      while (_arrsLock.testAndSet()) do chpl_task_yield();
    }

    inline proc _unlock_arrs() {
      _arrsLock.clear();
    }

    // used for associative domains/arrays
    proc _backupArrays() {
      for arr in _arrs do
        arr._backupArray();
    }

    proc _removeArrayBackups() {
      for arr in _arrs do
        arr._removeArrayBackup();
    }

    proc _preserveArrayElements(oldslot, newslot) {
      for arr in _arrs do
        arr._preserveArrayElement(oldslot, newslot);
    }

    inline proc incRefCount(cnt=1) {
      compilerAssert(!noRefCount);
      if debugDomRefCount > 0 {
        const cnt = _domCnt.read();
        if debugDomRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- INC _domCnt (%016lx) was %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
          halt("_domCnt is bogus!");
      }
      _domCnt.inc(cnt);
    }

    inline proc decRefCount() {
      compilerAssert(!noRefCount);
      const cnt = _domCnt.dec(); //_domCnt.fetchSub(1)-1;
      if debugDomRefCount > 0 {
        if debugDomRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- DEC _domCnt (%016lx) now %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
            halt("_domCnt is bogus!");
        // Poison the domCount, so an attempt to move it away from zero a
        // second time will fail
        if cnt == 0 then _domCnt.dec();
      }
      return cnt;
    }

    proc dsiSupportsPrivatization() param return false;
    proc dsiRequiresPrivatization() param return false;

    // false for default distribution so that we don't increment the
    // default distribution's reference count and add domains to the
    // default distribution's list of domains
    proc linksDistribution() param return true;

    // dynamically-dispatched counterpart of linksDistribution
    proc dsiLinksDistribution() return true;

    proc dsiDisplayRepresentation() { }
  }

  class BaseRectangularDom : BaseDom {
    proc dsiClear() {
      halt("clear not implemented for this distribution");
    }

    proc clearForIteratableAssign() {
      compilerError("Illegal assignment to a rectangular domain");
    }

    proc dsiAdd(x) {
      compilerError("Cannot add indices to a rectangular domain");
    }

    proc dsiRemove(x) {
      compilerError("Cannot remove indices from a rectangular domain");
    }
  }

  class BaseSparseDom : BaseDom {
    proc dsiClear() {
      halt("clear not implemented for this distribution");
    }

    proc clearForIteratableAssign() {
      dsiClear();
    }
  }

  class BaseAssociativeDom : BaseDom {
    proc dsiClear() {
      halt("clear not implemented for this distribution");
    }

    proc clearForIteratableAssign() {
      dsiClear();
    }
  }

  class BaseOpaqueDom : BaseDom {
    proc dsiClear() {
      halt("clear not implemented for this distribution");
    }

    proc clearForIteratableAssign() {
      dsiClear();
    }
  }

  //
  // Abstract array class
  //
  pragma "base array"
  class BaseArr {
    // The common case seems to be local access to this class, so we
    // will use explicit processor atomics, even when network
    // atomics are available
    var _arrCnt: atomic_refcnt; // array reference count
    var _arrAlias: BaseArr;    // reference to base array if an alias

    proc dsiStaticFastFollowCheck(type leadType) param return false;

    proc dsiGetBaseDom(): BaseDom {
      halt("internal error: dsiGetBaseDom is not implemented");
      return nil;
    }

    pragma "dont disable remote value forwarding"
    proc destroyArr(): int {
      compilerAssert(!noRefCount);
      var cnt = decRefCount();
      if cnt == 0 {
        if _arrAlias {
          on _arrAlias {
            var cnt = _arrAlias.destroyArr();
            if cnt == 0 then
              delete _arrAlias;
          }
        } else {
          dsiDestroyData();
        }
      }
      return cnt;
    }

    proc dsiDestroyData() { }

    proc dsiReallocate(d: domain) {
      halt("reallocating not supported for this array type");
    }

    proc dsiPostReallocate() {
    }

    // This method is unsatisfactory -- see bradc's commit entries of
    // 01/02/08 around 14:30 for details
    proc _purge( ind: int) {
      halt("purging not supported for this array type");
    }

    proc _resize( length: int, old_map) {
      halt("resizing not supported for this array type");
    }

    //
    // Ultimately, these routines should not appear here; instead, we'd
    // like to do a dynamic cast in the sparse array class(es) that call
    // these routines in order to call them directly and avoid the
    // dynamic dispatch and leaking of this name to the class.  In order
    // to do this we'd need to hoist eltType to the base class, which
    // would require better subclassing of generic classes.  A good
    // summer project for Jonathan?
    //
    proc sparseShiftArray(shiftrange, initrange) {
      halt("sparseGrowDomain not supported for non-sparse arrays");
    }

    proc sparseShiftArrayBack(shiftrange) {
      halt("sparseShiftArrayBack not supported for non-sparse arrays");
    }

    // methods for associative arrays
    proc clearEntry(idx, haveLock:bool = false) {
      halt("clearEntry() not supported for non-associative arrays");
    }

    proc _backupArray() {
      halt("_backupArray() not supported for non-associative arrays");
    }

    proc _removeArrayBackup() {
      halt("_removeArrayBackup() not supported for non-associative arrays");
    }

    proc _preserveArrayElement(oldslot, newslot) {
      halt("_preserveArrayElement() not supported for non-associative arrays");
    }

    inline proc incRefCount(cnt=1) {
      compilerAssert(!noRefCount);
      if debugArrRefCount > 0 {
        const cnt = _arrCnt.read();
        if debugArrRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- INC _arrCnt (%016lx) was %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
          halt("_arrCnt is bogus!");
      }
      _arrCnt.inc(cnt);
    }

    inline proc decRefCount() {
      compilerAssert(!noRefCount);
      const cnt = _arrCnt.dec(); //_arrCnt.fetchSub(1)-1;
      if debugArrRefCount > 0 {
        if debugArrRefCount > 1 {
          extern proc printf(fmt: c_string, arg...);
          printf("----- DEC _arrCnt (%016lx) now %ld\n",
                 __primitive("cast", uint(64), this), cnt);
        }
        if cnt < 0 || cnt > 10000 then
            halt("_arrCnt is bogus!");
        // Poison the arrCount, so an attempt to move it away from zero a
        // second time will fail
        if cnt == 0 then _arrCnt.dec();
      }
      return cnt;
    }

    proc dsiSupportsAlignedFollower() param return false;

    proc dsiSupportsPrivatization() param return false;
    proc dsiRequiresPrivatization() param return false;

    proc dsiSupportsBulkTransfer() param return false;
    proc doiCanBulkTransfer() param return false;
    proc doiBulkTransfer(B){
      halt("This array type does not support bulk transfer.");
    }

    proc dsiDisplayRepresentation() { }
    proc isDefaultRectangular() param return false;
    proc dsiSupportsBulkTransferInterface() param return false;
    proc doiCanBulkTransferStride() param return false;
  }

}