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

New functions FILL-ARRAY-WITH-ELT and FILL-ARRAY-WITH-SEQ used to inline MAKE-ARRAY and to speed it up.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-03-07 11:51:29 +01:00
parent d4c9460c32
commit 0a4ae4ebd2
6 changed files with 149 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

125
src/c/array.d
View file

@ -1122,3 +1122,128 @@ ecl_reverse_subarray(cl_object x, cl_index i0, cl_index i1)
FEbad_aet();
}
}
cl_object
si_fill_array_with_elt(cl_object x, cl_object elt, cl_object start, cl_object end)
{
cl_elttype t = ecl_array_elttype(x);
cl_index first = fixnnint(start);
cl_index last = Null(end)? x->array.dim : fixnnint(end);
if (first >= last) {
goto END;
}
switch (t) {
case aet_object: {
cl_object *p = x->vector.self.t + first;
for (first = last - first; first; --first, ++p) { *p = elt; }
break;
}
case aet_bc: {
ecl_base_char e = ecl_char_code(elt);
ecl_base_char *p = x->vector.self.bc + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#ifdef ECL_UNICODE
case aet_ch: {
ecl_character e = ecl_char_code(elt);
ecl_character *p = x->vector.self.ch + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
case aet_fix: {
cl_fixnum e = fixint(elt);
cl_fixnum *p = x->vector.self.fix + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_index: {
cl_index e = fixnnint(elt);
cl_index *p = x->vector.self.index + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_sf: {
float e = ecl_to_float(elt);
float *p = x->vector.self.sf + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_df: {
double e = ecl_to_double(elt);
double *p = x->vector.self.df + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_b8: {
uint8_t e = ecl_to_uint8_t(elt);
uint8_t *p = x->vector.self.b8 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_i8: {
int8_t e = ecl_to_int8_t(elt);
int8_t *p = x->vector.self.i8 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#ifdef ecl_uint16_t
case aet_b16: {
ecl_uint16_t e = ecl_to_uint16_t(elt);
ecl_uint16_t *p = x->vector.self.b16 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_i16: {
ecl_int16_t e = ecl_to_int16_t(elt);
ecl_int16_t *p = x->vector.self.i16 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
#ifdef ecl_uint32_t
case aet_b32: {
ecl_uint32_t e = ecl_to_uint32_t(elt);
ecl_uint32_t *p = x->vector.self.b32 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_i32: {
ecl_int32_t e = ecl_to_int32_t(elt);
ecl_int32_t *p = x->vector.self.i32 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
#ifdef ecl_uint64_t
case aet_b64: {
ecl_uint64_t e = ecl_to_uint64_t(elt);
ecl_uint64_t *p = x->vector.self.b64 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case aet_i64: {
ecl_int64_t e = ecl_to_int64_t(elt);
ecl_int64_t *p = x->vector.self.i64 + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
case aet_bit: {
int i = ecl_fixnum_in_range(@'si::aset',"bit",elt,0,1);
for (last -= first, first += x->vector.offset; last; --last, ++first) {
int mask = 0200>>first%CHAR_BIT;
if (i == 0)
x->vector.self.bit[first/CHAR_BIT] &= ~mask;
else
x->vector.self.bit[first/CHAR_BIT] |= mask;
}
break;
}
default:
FEbad_aet();
}
END:
@(return x)
}

2
src/c/symbols_list.h
View file

@ -1769,5 +1769,7 @@ cl_symbols[] = {
{EXT_ "HEAP-SIZE", EXT_ORDINARY, si_heap_size, -1, OBJNULL},
#endif
{EXT_ "FILL-ARRAY-WITH-ELT", EXT_ORDINARY, si_fill_array_with_elt, 4, OBJNULL},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

2
src/c/symbols_list2.h
View file

@ -1769,5 +1769,7 @@ cl_symbols[] = {
{EXT_ "HEAP-SIZE","si_heap_size"},
#endif
{EXT_ "FILL-ARRAY-WITH-ELT","si_fill_array_with_elt"},
/* Tag for end of list */
{NULL,NULL}};

2
src/h/external.h
View file

@ -302,6 +302,7 @@ extern ECL_API cl_object si_replace_array(cl_object old_obj, cl_object new_obj);
extern ECL_API cl_object cl_aref _ARGS((cl_narg narg, cl_object x, ...));
extern ECL_API cl_object si_aset _ARGS((cl_narg narg, cl_object v, cl_object x, ...));
extern ECL_API cl_object si_make_pure_array(cl_object etype, cl_object dims, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff);
extern ECL_API cl_object si_fill_array_with_elt(cl_object array, cl_object elt, cl_object start, cl_object end);
extern ECL_API cl_index ecl_to_index(cl_object n);
extern ECL_API cl_object ecl_aref(cl_object x, cl_index index);
@ -1663,6 +1664,7 @@ extern ECL_API cl_object ecl_alloc_adjustable_extended_string(cl_index l);
/* arraylib.lsp */
extern ECL_API cl_object cl_make_array _ARGS((cl_narg narg, cl_object V1, ...));
extern ECL_API cl_object si_fill_array_with_seq _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern ECL_API cl_object cl_vector _ARGS((cl_narg narg, ...));
extern ECL_API cl_object cl_array_dimensions _ARGS((cl_narg narg, cl_object V1, ...));
extern ECL_API cl_object cl_array_in_bounds_p _ARGS((cl_narg narg, cl_object V1, ...));

12
src/h/object.h
View file

@ -391,16 +391,16 @@ union ecl_array_data {
uint8_t *b8;
int8_t *i8;
#ifdef ecl_uint16_t
uint16_t *b16;
int16_t *i16;
ecl_uint16_t *b16;
ecl_int16_t *i16;
#endif
#ifdef ecl_uint32_t
uint32_t *b32;
int32_t *i32;
ecl_uint32_t *b32;
ecl_int32_t *i32;
#endif
#ifdef ecl_uint64_t
uint64_t *b64;
int64_t *i64;
ecl_uint64_t *b64;
ecl_int64_t *i64;
#endif
float *sf;
double *df;

24
src/lsp/arraylib.lsp
View file

@ -46,16 +46,16 @@ contiguous block."
(let ((x (sys:make-pure-array element-type dimensions adjustable
fill-pointer displaced-to displaced-index-offset)))
(declare (array x))
(when initial-element-supplied-p
(dotimes (i (array-total-size x))
(declare (fixnum i))
(sys::row-major-aset x i initial-element)))
(when initial-contents-supplied-p
(fill-array x initial-contents))
x))
(cond (initial-element-supplied-p
(when initial-contents-supplied-p
(error "MAKE-ARRAY: Cannot supply both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
(fill-array-with-elt x initial-element 0 nil))
(initial-contents-supplied-p
(fill-array-with-seq x initial-contents))
(t
x))))
(defun fill-array (array initial-contents)
(declare (si::c-local))
(defun fill-array-with-seq (array initial-contents)
(labels ((iterate-over-contents (array contents dims written)
(declare (fixnum written)
(array array)
@ -77,7 +77,8 @@ contiguous block."
(let ((dims (array-dimensions array)))
(if dims
(iterate-over-contents array initial-contents dims 0)
(setf (aref array) initial-contents)))))
(setf (aref array) initial-contents))))
array)
(defun vector (&rest objects)
@ -85,8 +86,7 @@ contiguous block."
Creates and returns a simple-vector, with the N-th OBJECT being the N-th
element."
(let ((a (si:make-vector t (length objects) nil nil nil 0)))
(fill-array a objects)
a))
(fill-array-with-seq a objects)))
(defun array-dimensions (array)
"Args: (array)