OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [m4/] [spread.m4] - Blame information for rev 733

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
`/* Special implementation of the SPREAD intrinsic
2
   Copyright 2008, 2009 Free Software Foundation, Inc.
3
   Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
4
   spread_generic.c written by Paul Brook <paul@nowt.org>
5
 
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
 
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
 
13
Ligbfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
 
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
 
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
 
27
#include "libgfortran.h"
28
#include <stdlib.h>
29
#include <assert.h>
30
#include <string.h>'
31
 
32
include(iparm.m4)dnl
33
 
34
`#if defined (HAVE_'rtype_name`)
35
 
36
void
37
spread_'rtype_code` ('rtype` *ret, const 'rtype` *source,
38
                 const index_type along, const index_type pncopies)
39
{
40
  /* r.* indicates the return array.  */
41
  index_type rstride[GFC_MAX_DIMENSIONS];
42
  index_type rstride0;
43
  index_type rdelta = 0;
44
  index_type rrank;
45
  index_type rs;
46
  'rtype_name` *rptr;
47
  'rtype_name` * restrict dest;
48
  /* s.* indicates the source array.  */
49
  index_type sstride[GFC_MAX_DIMENSIONS];
50
  index_type sstride0;
51
  index_type srank;
52
  const 'rtype_name` *sptr;
53
 
54
  index_type count[GFC_MAX_DIMENSIONS];
55
  index_type extent[GFC_MAX_DIMENSIONS];
56
  index_type n;
57
  index_type dim;
58
  index_type ncopies;
59
 
60
  srank = GFC_DESCRIPTOR_RANK(source);
61
 
62
  rrank = srank + 1;
63
  if (rrank > GFC_MAX_DIMENSIONS)
64
    runtime_error ("return rank too large in spread()");
65
 
66
  if (along > rrank)
67
      runtime_error ("dim outside of rank in spread()");
68
 
69
  ncopies = pncopies;
70
 
71
  if (ret->data == NULL)
72
    {
73
 
74
      size_t ub, stride;
75
 
76
      /* The front end has signalled that we need to populate the
77
         return array descriptor.  */
78
      ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
79
      dim = 0;
80
      rs = 1;
81
      for (n = 0; n < rrank; n++)
82
        {
83
          stride = rs;
84
          if (n == along - 1)
85
            {
86
              ub = ncopies - 1;
87
              rdelta = rs;
88
              rs *= ncopies;
89
            }
90
          else
91
            {
92
              count[dim] = 0;
93
              extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
94
              sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
95
              rstride[dim] = rs;
96
 
97
              ub = extent[dim] - 1;
98
              rs *= extent[dim];
99
              dim++;
100
            }
101
          GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
102
        }
103
      ret->offset = 0;
104
 
105
      /* internal_malloc_size allocates a single byte for zero size.  */
106
      ret->data = internal_malloc_size (rs * sizeof('rtype_name`));
107
      if (rs <= 0)
108
        return;
109
    }
110
  else
111
    {
112
      int zero_sized;
113
 
114
      zero_sized = 0;
115
 
116
      dim = 0;
117
      if (GFC_DESCRIPTOR_RANK(ret) != rrank)
118
        runtime_error ("rank mismatch in spread()");
119
 
120
      if (unlikely (compile_options.bounds_check))
121
        {
122
          for (n = 0; n < rrank; n++)
123
            {
124
              index_type ret_extent;
125
 
126
              ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
127
              if (n == along - 1)
128
                {
129
                  rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
130
 
131
                  if (ret_extent != ncopies)
132
                    runtime_error("Incorrect extent in return value of SPREAD"
133
                                  " intrinsic in dimension %ld: is %ld,"
134
                                  " should be %ld", (long int) n+1,
135
                                  (long int) ret_extent, (long int) ncopies);
136
                }
137
              else
138
                {
139
                  count[dim] = 0;
140
                  extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
141
                  if (ret_extent != extent[dim])
142
                    runtime_error("Incorrect extent in return value of SPREAD"
143
                                  " intrinsic in dimension %ld: is %ld,"
144
                                  " should be %ld", (long int) n+1,
145
                                  (long int) ret_extent,
146
                                  (long int) extent[dim]);
147
 
148
                  if (extent[dim] <= 0)
149
                    zero_sized = 1;
150
                  sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
151
                  rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
152
                  dim++;
153
                }
154
            }
155
        }
156
      else
157
        {
158
          for (n = 0; n < rrank; n++)
159
            {
160
              if (n == along - 1)
161
                {
162
                  rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
163
                }
164
              else
165
                {
166
                  count[dim] = 0;
167
                  extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
168
                  if (extent[dim] <= 0)
169
                    zero_sized = 1;
170
                  sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
171
                  rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
172
                  dim++;
173
                }
174
            }
175
        }
176
 
177
      if (zero_sized)
178
        return;
179
 
180
      if (sstride[0] == 0)
181
        sstride[0] = 1;
182
    }
183
  sstride0 = sstride[0];
184
  rstride0 = rstride[0];
185
  rptr = ret->data;
186
  sptr = source->data;
187
 
188
  while (sptr)
189
    {
190
      /* Spread this element.  */
191
      dest = rptr;
192
      for (n = 0; n < ncopies; n++)
193
        {
194
          *dest = *sptr;
195
          dest += rdelta;
196
        }
197
      /* Advance to the next element.  */
198
      sptr += sstride0;
199
      rptr += rstride0;
200
      count[0]++;
201
      n = 0;
202
      while (count[n] == extent[n])
203
        {
204
          /* When we get to the end of a dimension, reset it and increment
205
             the next dimension.  */
206
          count[n] = 0;
207
          /* We could precalculate these products, but this is a less
208
             frequently used path so probably not worth it.  */
209
          sptr -= sstride[n] * extent[n];
210
          rptr -= rstride[n] * extent[n];
211
          n++;
212
          if (n >= srank)
213
            {
214
              /* Break out of the loop.  */
215
              sptr = NULL;
216
              break;
217
            }
218
          else
219
            {
220
              count[n]++;
221
              sptr += sstride[n];
222
              rptr += rstride[n];
223
            }
224
        }
225
    }
226
}
227
 
228
/* This version of spread_internal treats the special case of a scalar
229
   source.  This is much simpler than the more general case above.  */
230
 
231
void
232
spread_scalar_'rtype_code` ('rtype` *ret, const 'rtype_name` *source,
233
                        const index_type along, const index_type pncopies)
234
{
235
  int n;
236
  int ncopies = pncopies;
237
  'rtype_name` * restrict dest;
238
  index_type stride;
239
 
240
  if (GFC_DESCRIPTOR_RANK (ret) != 1)
241
    runtime_error ("incorrect destination rank in spread()");
242
 
243
  if (along > 1)
244
    runtime_error ("dim outside of rank in spread()");
245
 
246
  if (ret->data == NULL)
247
    {
248
      ret->data = internal_malloc_size (ncopies * sizeof ('rtype_name`));
249
      ret->offset = 0;
250
      GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
251
    }
252
  else
253
    {
254
      if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
255
                           / GFC_DESCRIPTOR_STRIDE(ret,0))
256
        runtime_error ("dim too large in spread()");
257
    }
258
 
259
  dest = ret->data;
260
  stride = GFC_DESCRIPTOR_STRIDE(ret,0);
261
 
262
  for (n = 0; n < ncopies; n++)
263
    {
264
      *dest = *source;
265
      dest += stride;
266
    }
267
}
268
 
269
#endif
270
'

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.