mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-09 02:33:14 -08:00
Code Issues Projects Releases Packages Wiki Activity

Minimized consing in VECTOR-PUSH-EXTEND and simplified sequence routines with two new abstractions ecl_copy/reverse_subarray().

Browse source
This commit is contained in:
jjgarcia 2005-06-27 08:14:04 +00:00
parent 031db375ce
commit 7cc625e136
9 changed files with 206 additions and 263 deletions
Download patch file Download diff file Expand all files Collapse all files

2
msvc/ecl-threads.def
View file

@ -57,6 +57,8 @@ EXPORTS
array_elttype
ecl_symbol_to_elttype
ecl_elttype_to_symbol
ecl_copy_subarray
ecl_reverse_subarray
; assignment.c

2
msvc/ecl.def
View file

@ -57,6 +57,8 @@ EXPORTS
array_elttype
ecl_symbol_to_elttype
ecl_elttype_to_symbol
ecl_copy_subarray
ecl_reverse_subarray
; assignment.c

114
src/c/array.d
View file

@ -15,8 +15,21 @@
*/
#include <limits.h>
#include <string.h>
#include "ecl.h"
static const cl_index ecl_aet_size[] = {
sizeof(cl_object), /* aet_object */
sizeof(float), /* aet_sf */
sizeof(double), /* aet_lf */
0, /* aet_bit: cannot be handled with this code */
sizeof(cl_fixnum), /* aet_fix */
sizeof(cl_index), /* aet_index */
sizeof(uint8_t), /* aet_b8 */
sizeof(int8_t), /* aet_i8 */
sizeof(unsigned char) /* aet_ch */
};
static void displace (cl_object from, cl_object to, cl_object offset);
static void check_displaced (cl_object dlist, cl_object orig, cl_index newdim);
@ -842,3 +855,104 @@ si_replace_array(cl_object olda, cl_object newa)
OUTPUT:
@(return olda)
}
void
ecl_copy_subarray(cl_object dest, cl_index i0, cl_object orig, cl_index i1, cl_index l)
{
cl_elttype t = array_elttype(dest);
if (i0 + l > dest->array.dim) {
l = dest->array.dim - i0;
}
if (i1 + l > orig->array.dim) {
l = orig->array.dim - i1;
}
if (t != array_elttype(orig) || t == aet_bit) {
while (l--) {
aset(dest, i0++, aref(orig, i1++));
}
} else if (t >= 0 && t <= aet_last_type) {
cl_index elt_size = ecl_aet_size[t];
memcpy(dest->array.self.ch + i0 * elt_size,
orig->array.self.ch + i1 * elt_size,
l * elt_size);
} else {
FEerror("Bad array type", 0);
}
}
void
ecl_reverse_subarray(cl_object x, cl_index i0, cl_index i1)
{
cl_elttype t = array_elttype(x);
cl_index i, j;
if (i1 >= x->array.dim) {
i1 = x->array.dim;
}
switch (t) {
case aet_object:
case aet_fix:
case aet_index:
for (i = 0, j = i1-1; i < j; i++, --j) {
cl_object y = x->vector.self.t[i];
x->vector.self.t[i] = x->vector.self.t[j];
x->vector.self.t[j] = y;
}
break;
case aet_sf:
for (i = 0, j = i1-1; i < j; i++, --j) {
float y = x->array.self.sf[i];
x->array.self.sf[i] = x->array.self.sf[j];
x->array.self.sf[j] = y;
}
break;
case aet_lf:
for (i = 0, j = i1-1; i < j; i++, --j) {
double y = x->array.self.lf[i];
x->array.self.lf[i] = x->array.self.lf[j];
x->array.self.lf[j] = y;
}
break;
case aet_b8:
for (i = 0, j = i1-1; i < j; i++, --j) {
uint8_t y = x->array.self.b8[i];
x->array.self.b8[i] = x->array.self.b8[j];
x->array.self.b8[j] = y;
}
break;
case aet_i8:
for (i = 0, j = i1-1; i < j; i++, --j) {
int8_t y = x->array.self.i8[i];
x->array.self.i8[i] = x->array.self.i8[j];
x->array.self.i8[j] = y;
}
break;
case aet_ch:
for (i = 0, j = i1-1; i < j; i++, --j) {
unsigned char y = x->array.self.ch[i];
x->array.self.ch[i] = x->array.self.ch[j];
x->array.self.ch[j] = y;
}
break;
case aet_bit:
for (i = x->vector.offset,
j = i1 + x->vector.offset - 1;
i < j;
i++, --j) {
int k = x->array.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT);
if (x->array.self.bit[j/CHAR_BIT]&(0200>>j%CHAR_BIT))
x->array.self.bit[i/CHAR_BIT]
|= 0200>>i%CHAR_BIT;
else
x->array.self.bit[i/CHAR_BIT]
&= ~(0200>>i%CHAR_BIT);
if (k)
x->array.self.bit[j/CHAR_BIT]
|= 0200>>j%CHAR_BIT;
else
x->array.self.bit[j/CHAR_BIT]
&= ~(0200>>j%CHAR_BIT);
}
default:
FEerror("Bad array type", 0);
}
}

2
src/c/read.d
View file

@ -801,7 +801,6 @@ sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d)
}
} else if (fixed_size) {
v = cl_alloc_simple_vector(dim, aet_object);
v->vector.self.t = (cl_object *)cl_alloc_align(dim * sizeof(cl_object), sizeof(cl_object));
for (i = 0; i < dim; i++) {
if (in != OBJNULL) {
x = read_object_with_delimiter(in, ')');
@ -871,7 +870,6 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d)
dim = dimcount;
}
x = cl_alloc_simple_bitvector(dim);
x->vector.self.bit = (byte *)cl_alloc_atomic((dim + CHAR_BIT - 1)/CHAR_BIT);
for (i = 0; i < dim; i++) {
elt = (i < dimcount) ? cl_env.stack[sp+i] : last;
if (elt == MAKE_FIXNUM(0))

249
src/c/sequence.d
View file

@ -26,28 +26,26 @@ cl_alloc_simple_vector(cl_index l, cl_elttype aet)
{
cl_object x;
x = cl_alloc_object(t_vector);
x->vector.hasfillp = FALSE;
x->vector.adjustable = FALSE;
x->vector.displaced = Cnil;
x->vector.dim = x->vector.fillp = l;
x->vector.self.t = NULL;
x->vector.elttype = (short)aet;
return(x);
}
cl_object
cl_alloc_simple_bitvector(cl_index l)
{
cl_object x;
x = cl_alloc_object(t_bitvector);
x->vector.hasfillp = FALSE;
x->vector.adjustable = FALSE;
x->vector.displaced = Cnil;
x->vector.dim = x->vector.fillp = l;
x->vector.offset = 0;
x->vector.self.bit = NULL;
if (aet == aet_ch)
return cl_alloc_simple_string(l);
if (aet == aet_bit) {
x = cl_alloc_object(t_bitvector);
x->vector.hasfillp = FALSE;
x->vector.adjustable = FALSE;
x->vector.displaced = Cnil;
x->vector.dim = x->vector.fillp = l;
x->vector.offset = 0;
x->vector.self.bit = NULL;
} else {
x = cl_alloc_object(t_vector);
x->vector.hasfillp = FALSE;
x->vector.adjustable = FALSE;
x->vector.displaced = Cnil;
x->vector.dim = x->vector.fillp = l;
x->vector.self.t = NULL;
x->vector.elttype = (short)aet;
}
array_allocself(x);
return(x);
}
@ -184,68 +182,16 @@ E:
@(return x)
case t_vector:
if (s > sequence->vector.fillp)
goto ILLEGAL_START_END;
if (e < 0)
e = sequence->vector.fillp;
else if (e < s || e > sequence->vector.fillp)
goto ILLEGAL_START_END;
x = cl_alloc_simple_vector(e - s, (cl_elttype)sequence->vector.elttype);
array_allocself(x);
switch ((cl_elttype)sequence->vector.elttype) {
case aet_object:
case aet_fix:
case aet_index:
case aet_sf:
for (i = s, j = 0; i < e; i++, j++)
x->vector.self.t[j] = sequence->vector.self.t[i];
break;
case aet_lf:
for (i = s, j = 0; i < e; i++, j++)
x->array.self.lf[j] =
sequence->array.self.lf[i];
break;
case aet_b8:
case aet_i8:
for (i = s, j = 0; i < e; i++, j++)
x->vector.self.b8[j] = sequence->vector.self.b8[i];
break;
default:
internal_error("subseq");
}
@(return x)
case t_string:
if (s > sequence->string.fillp)
goto ILLEGAL_START_END;
if (e < 0)
e = sequence->string.fillp;
else if (e < s || e > sequence->string.fillp)
goto ILLEGAL_START_END;
x = cl_alloc_simple_string(e - s);
for (i = s, j = 0; i < e; i++, j++)
x->string.self[j] = sequence->string.self[i];
@(return x)
case t_bitvector:
case t_string:
if (s > sequence->vector.fillp)
goto ILLEGAL_START_END;
if (e < 0)
e = sequence->vector.fillp;
else if (e < s || e > sequence->vector.fillp)
goto ILLEGAL_START_END;
x = cl_alloc_simple_bitvector(e - s);
x->vector.self.bit = (byte *)cl_alloc_atomic((e-s+CHAR_BIT-1)/CHAR_BIT);
s += sequence->vector.offset;
e += sequence->vector.offset;
for (i = s, j = 0; i < e; i++, j++)
if (sequence->vector.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT))
x->vector.self.bit[j/CHAR_BIT]
|= 0200>>j%CHAR_BIT;
else
x->vector.self.bit[j/CHAR_BIT]
&= ~(0200>>j%CHAR_BIT);
x = cl_alloc_simple_vector(e - s, array_elttype(sequence));
ecl_copy_subarray(x, 0, sequence, s, e-s);
@(return x)
default:
@ -301,92 +247,44 @@ length(cl_object x)
cl_object
cl_reverse(cl_object seq)
{
cl_object x, y;
cl_fixnum i, j, k;
cl_object output, x;
switch (type_of(seq)) {
case t_symbol:
if (Null(seq))
y = Cnil;
output = Cnil;
else
FEwrong_type_argument(@'sequence', seq);
break;
case t_cons:
y = Cnil;
for (x = seq; !endp(x); x = CDR(x))
y = CONS(CAR(x), y);
case t_cons: {
for (x = seq, output = Cnil; !endp(x); x = CDR(x))
output = CONS(CAR(x), output);
break;
}
case t_vector:
x = seq;
k = x->vector.fillp;
y = cl_alloc_simple_vector(k, (cl_elttype)x->vector.elttype);
array_allocself(y);
switch ((cl_elttype)x->vector.elttype) {
case aet_object:
case aet_fix:
case aet_index:
case aet_sf:
for (j = k - 1, i = 0; j >=0; --j, i++)
y->vector.self.t[j] = x->vector.self.t[i];
break;
case aet_lf:
for (j = k - 1, i = 0; j >=0; --j, i++)
y->array.self.lf[j] = x->array.self.lf[i];
break;
case aet_b8:
for (j = k - 1, i = 0; j >=0; --j, i++)
y->array.self.b8[j] = x->array.self.b8[i];
break;
case aet_i8:
for (j = k - 1, i = 0; j >=0; --j, i++)
y->array.self.i8[j] = x->array.self.i8[i];
break;
default:
internal_error("reverse");
}
break;
case t_string:
x = seq;
y = cl_alloc_simple_string(x->string.fillp);
for (j = x->string.fillp - 1, i = 0; j >=0; --j, i++)
y->string.self[j] = x->string.self[i];
break;
case t_bitvector:
x = seq;
y = cl_alloc_simple_bitvector(x->vector.fillp);
y->vector.self.bit = (byte *)cl_alloc_atomic((x->vector.fillp+CHAR_BIT-1)/CHAR_BIT);
for (j = x->vector.fillp - 1, i = x->vector.offset;
j >=0;
--j, i++)
if (x->vector.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT))
y->vector.self.bit[j/CHAR_BIT] |= 0200>>j%CHAR_BIT;
else
y->vector.self.bit[j/CHAR_BIT] &= ~(0200>>j%CHAR_BIT);
case t_string:
output = cl_alloc_simple_vector(seq->vector.fillp, array_elttype(seq));
ecl_copy_subarray(output, 0, seq, 0, seq->vector.fillp);
ecl_reverse_subarray(output, 0, seq->vector.fillp);
break;
default:
FEwrong_type_argument(@'sequence', seq);
}
@(return y)
@(return output)
}
cl_object
cl_nreverse(cl_object seq)
{
cl_object x, y, z;
cl_fixnum i, j, k;
switch (type_of(seq)) {
case t_symbol:
if (!Null(seq))
FEwrong_type_argument(@'sequence', seq);
break;
case t_cons:
case t_cons: {
cl_object x, y, z;
for (x = Cnil, y = seq; !endp(CDR(y));) {
z = y;
y = CDR(y);
@ -396,82 +294,11 @@ cl_nreverse(cl_object seq)
CDR(y) = x;
seq = y;
break;
}
case t_vector:
x = seq;
k = x->vector.fillp;
switch ((cl_elttype)x->vector.elttype) {
case aet_object:
case aet_fix:
case aet_index:
for (i = 0, j = k - 1; i < j; i++, --j) {
y = x->vector.self.t[i];
x->vector.self.t[i] = x->vector.self.t[j];
x->vector.self.t[j] = y;
}
break;
case aet_sf:
for (i = 0, j = k - 1; i < j; i++, --j) {
float y = x->array.self.sf[i];
x->array.self.sf[i] = x->array.self.sf[j];
x->array.self.sf[j] = y;
}
break;
case aet_lf:
for (i = 0, j = k - 1; i < j; i++, --j) {
double y = x->array.self.lf[i];
x->array.self.lf[i] = x->array.self.lf[j];
x->array.self.lf[j] = y;
}
break;
case aet_b8:
for (i = 0, j = k - 1; i < j; i++, --j) {
uint8_t y = x->array.self.b8[i];
x->array.self.b8[i] = x->array.self.b8[j];
x->array.self.b8[j] = y;
}
break;
case aet_i8:
for (i = 0, j = k - 1; i < j; i++, --j) {
int8_t y = x->array.self.i8[i];
x->array.self.i8[i] = x->array.self.i8[j];
x->array.self.i8[j] = y;
}
break;
default:
internal_error("subseq");
}
break;
case t_string:
x = seq;
for (i = 0, j = x->string.fillp - 1; i < j; i++, --j) {
k = x->string.self[i];
x->string.self[i] = x->string.self[j];
x->string.self[j] = k;
}
break;
case t_bitvector:
x = seq;
for (i = x->vector.offset,
j = x->vector.fillp + x->vector.offset - 1;
i < j;
i++, --j) {
k = x->vector.self.bit[i/CHAR_BIT]&(0200>>i%CHAR_BIT);
if (x->vector.self.bit[j/CHAR_BIT]&(0200>>j%CHAR_BIT))
x->vector.self.bit[i/CHAR_BIT]
|= 0200>>i%CHAR_BIT;
else
x->vector.self.bit[i/CHAR_BIT]
&= ~(0200>>i%CHAR_BIT);
if (k)
x->vector.self.bit[j/CHAR_BIT]
|= 0200>>j%CHAR_BIT;
else
x->vector.self.bit[j/CHAR_BIT]
&= ~(0200>>j%CHAR_BIT);
}
ecl_reverse_subarray(seq, 0, seq->vector.fillp);
break;
default:
FEwrong_type_argument(@'sequence', seq);

2
src/cmp/sysfun.lsp
View file

@ -778,6 +778,8 @@
"@0;type_of(#0)==t_vector||
type_of(#0)==t_string||
type_of(#0)==t_bitvector"))
(VECTOR-PUSH (T VECTOR) FIXNUM T NIL)
(VECTOR-PUSH-EXTEND (T VECTOR) FIXNUM T NIL)
(SIMPLE-STRING-P (T) T NIL T)
(SIMPLE-BIT-VECTOR-P (T) T NIL T)
(SIMPLE-VECTOR-P (T) T NIL T)

4
src/h/external.h
View file

@ -271,6 +271,8 @@ extern void adjust_displaced(cl_object x, ptrdiff_t diff);
extern cl_elttype array_elttype(cl_object x);
extern cl_elttype ecl_symbol_to_elttype(cl_object x);
extern cl_object ecl_elttype_to_symbol(cl_elttype aet);
extern void ecl_copy_subarray(cl_object dest, cl_index i0, cl_object orig, cl_index i1, cl_index l);
extern void ecl_reverse_subarray(cl_object dest, cl_index i0, cl_index i1);
/* assignment.c */
@ -1189,7 +1191,7 @@ extern cl_object cl_nreverse(cl_object x);
extern cl_object cl_subseq _ARGS((cl_narg narg, cl_object sequence, cl_object start, ...));
extern cl_object cl_alloc_simple_vector(cl_index l, cl_elttype aet);
extern cl_object cl_alloc_simple_bitvector(cl_index l);
#define cl_alloc_simple_bitvector(l) cl_alloc_simple_vector((l), aet_bit)
extern cl_object elt(cl_object seq, cl_fixnum index);
extern cl_object elt_set(cl_object seq, cl_fixnum index, cl_object val);
extern cl_fixnum length(cl_object x);

1
src/h/object.h
View file

@ -212,6 +212,7 @@ typedef enum { /* array element type */
aet_b8, /* byte8 */
aet_i8, /* integer8 */
aet_ch, /* string-char */
aet_last_type = aet_ch
} cl_elttype;
union ecl_array_data {

93
src/lsp/arraylib.lsp
View file

@ -87,30 +87,6 @@ contiguous block."
(iterate-over-contents array initial-contents dims 0)
(setf (aref array) initial-contents)))))
(defun increment-cursor (cursor dimensions)
(declare (si::c-local))
(if (null cursor)
t
(let ((carry (increment-cursor (cdr cursor) (cdr dimensions))))
(if carry
(cond ((>= (the fixnum (1+ (the fixnum (car cursor))))
(the fixnum (car dimensions)))
(rplaca cursor 0)
t)
(t
(rplaca cursor
(the fixnum (1+ (the fixnum (car cursor)))))
nil))
nil))))
(defun sequence-cursor (sequence cursor)
(declare (si::c-local))
(if (null cursor)
sequence
(sequence-cursor (elt sequence (the fixnum (car cursor)))
(cdr cursor))))
(defun vector (&rest objects)
"Args: (&rest objects)
@ -280,25 +256,17 @@ Replaces ITEM for the element of VECTOR that is pointed to by the fill-pointer
of VECTOR and then increments the fill-pointer by one. If the new value of
the fill-pointer becomes too large, extends VECTOR for N more elements.
Returns the new value of the fill-pointer."
(let ((fp (fill-pointer vector)))
(declare (fixnum fp))
(cond ((< fp (the fixnum (array-dimension vector 0)))
(sys:aset new-element vector fp)
(sys:fill-pointer-set vector (the fixnum (1+ fp)))
fp)
(t
(adjust-array vector
(list (+ (array-dimension vector 0)
(or extension
(if (> (array-dimension vector 0) 0)
(array-dimension vector 0)
5))))
:element-type (array-element-type vector)
:fill-pointer fp)
(sys:aset new-element vector fp)
(sys:fill-pointer-set vector (the fixnum (1+ fp)))
fp))))
(let ((fp (fill-pointer vector))
(d (array-dimension vector 0)))
(declare (fixnum fp d))
(unless (< fp d)
(adjust-array vector
(list (+ d (or extension (max d 4))))
:element-type (array-element-type vector)
:fill-pointer fp))
(sys:aset new-element vector fp)
(sys:fill-pointer-set vector (the fixnum (1+ fp)))
fp))
(defun vector-pop (vector)
"Args: (vector)
@ -312,6 +280,38 @@ pointer is 0 already."
(sys:fill-pointer-set vector (the fixnum (1- fp)))
(aref vector (the fixnum (1- fp)))))
(defun copy-array-contents (dest orig)
(declare (si::c-local))
(labels
((do-copy (dest orig dims1 dims2 start1 start2)
(declare (array dest orig))
(let* ((d1 (pop dims1))
(d2 (pop dims2))
(l (min d1 d2))
(step1 (apply #'* dims1))
(step2 (apply #'* dims2))
(i1 start1)
(i2 start2))
(declare (fixnum d1 d2 l step1 step2 i1 i2))
(if (null dims1)
#+ecl-min
(dotimes (i l)
(declare (fixnum i))
(row-major-aset dest i1 (row-major-aref orig i2))
(incf i1)
(incf i2))
#-ecl-min
(ffi::c-inline (dest i1 orig i2 l)
(array :fixnum array :fixnum :fixnum) :void
"ecl_copy_subarray(#0, #1, #2, #3, #4)"
:one-liner t
:side-effects t)
(dotimes (i l)
(declare (fixnum i))
(do-copy dest orig dims1 dims2 i1 i2)
(incf i1 step1)
(incf i2 step2))))))
(do-copy dest orig (array-dimensions dest) (array-dimensions orig) 0 0)))
(defun adjust-array (array new-dimensions
&rest r
@ -339,11 +339,6 @@ adjustable array."
(let ((x (apply #'make-array new-dimensions :adjustable t :element-type element-type r)))
(declare (array x))
(unless (or displaced-to initial-contents)
(do ((cursor (make-list (length new-dimensions) :initial-element 0)))
(nil)
(when (apply #'array-in-bounds-p array cursor)
(apply #'aset (apply #'aref array cursor) x cursor))
(when (increment-cursor cursor new-dimensions)
(return nil))))
(copy-array-contents x array))
(sys:replace-array array x)
))