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

complex float: add compiler optimizations and ffi definitions

Browse source 
- add ffi implementation for long-float
- add ffi implementation for (complex float) types
- add compiler optimizations and definitions for complex float

We do not add c?float common constants (long-float i.e has optimizer
for 0.0 and -0.0), because we don't know if they are common at all and
if we think about it each would have four entries counting signed
zeros).

Also add informative comment about global-entries.
This commit is contained in:
Daniel Kochmański 2019-05-06 19:34:17 +02:00
parent 51594b8037
commit 8cc0ae7222
17 changed files with 212 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

44
src/c/ffi.d
View file

@ -117,6 +117,14 @@ ecl_foreign_type_table[] = {
FFI_DESC(@':object', cl_object),
FFI_DESC(@':float', float),
FFI_DESC(@':double', double),
#ifdef ECL_LONG_FLOAT
FFI_DESC(@':long-double', long double),
#endif
#ifdef ECL_COMPLEX_FLOAT
FFI_DESC(@':csfloat', _Complex float),
FFI_DESC(@':cdfloat', _Complex double),
FFI_DESC(@':clfloat', _Complex long double),
#endif
{@':void', 0, 0}
};
@ -175,6 +183,14 @@ static ffi_type *ecl_type_to_libffi_type[] = {
&ffi_type_pointer, /*@':object',*/
&ffi_type_float, /*@':float',*/
&ffi_type_double, /*@':double',*/
#ifdef ECL_LONG_FLOAT
&ffi_type_longdouble, /*@':long-double',*/
#endif
#ifdef ECL_COMPLEX_FLOAT
&ffi_type_complex_float, /*@':csfloat',*/
&ffi_type_complex_double, /*@':cdfloat',*/
&ffi_type_complex_longdouble, /*@':clfloat',*/
#endif
&ffi_type_void /*@':void'*/
};
#endif /* HAVE_LIBFFI */
@ -500,6 +516,18 @@ ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag)
return ecl_make_single_float(*(float *)p);
case ECL_FFI_DOUBLE:
return ecl_make_double_float(*(double *)p);
#ifdef ECL_LONG_FLOAT
case ECL_FFI_LONG_DOUBLE:
return ecl_make_long_float(*(long double *)p);
#endif
#ifdef ECL_COMPLEX_FLOAT
case ECL_FFI_CSFLOAT:
return ecl_make_csfloat(*(_Complex float *)p);
case ECL_FFI_CDFLOAT:
return ecl_make_cdfloat(*(_Complex double *)p);
case ECL_FFI_CLFLOAT:
return ecl_make_clfloat(*(_Complex long double *)p);
#endif
case ECL_FFI_VOID:
return ECL_NIL;
default:
@ -594,6 +622,22 @@ ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value)
case ECL_FFI_DOUBLE:
*(double *)p = ecl_to_double(value);
break;
#ifdef ECL_LONG_FLOAT
case ECL_FFI_LONG_DOUBLE:
*(long double *)p = ecl_to_long_double(value);
break;
#endif
#ifdef ECL_COMPLEX_FLOAT
case ECL_FFI_CSFLOAT:
*(_Complex float *)p = ecl_to_csfloat(value);
break;
case ECL_FFI_CDFLOAT:
*(_Complex double *)p = ecl_to_cdfloat(value);
break;
case ECL_FFI_CLFLOAT:
*(_Complex long double *)p = ecl_to_clfloat(value);
break;
#endif
case ECL_FFI_VOID:
break;
default:

4
src/c/symbols_list.h
View file

@ -1497,6 +1497,9 @@ cl_symbols[] = {
{SYS_ "ALIGNMENT-OF-FOREIGN-ELT-TYPE", SI_ORDINARY, si_alignment_of_foreign_elt_type, 1, OBJNULL},
{KEY_ "BYTE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CHAR", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CSFLOAT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CDFLOAT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CLFLOAT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CSTRING", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DOUBLE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "FIXNUM", KEYWORD, NULL, -1, OBJNULL},
@ -1507,6 +1510,7 @@ cl_symbols[] = {
{KEY_ "INT32-T", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INT64-T", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "LONG", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "LONG-DOUBLE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "LONG-LONG", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "POINTER-SELF", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "POINTER-VOID", KEYWORD, NULL, -1, OBJNULL},

4
src/c/symbols_list2.h
View file

@ -1497,6 +1497,9 @@ cl_symbols[] = {
{SYS_ "ALIGNMENT-OF-FOREIGN-ELT-TYPE","si_alignment_of_foreign_elt_type"},
{KEY_ "BYTE",NULL},
{KEY_ "CHAR",NULL},
{KEY_ "CSFLOAT",NULL},
{KEY_ "CDFLOAT",NULL},
{KEY_ "CLFLOAT",NULL},
{KEY_ "CSTRING",NULL},
{KEY_ "DOUBLE",NULL},
{KEY_ "FIXNUM",NULL},
@ -1507,6 +1510,7 @@ cl_symbols[] = {
{KEY_ "INT32-T",NULL},
{KEY_ "INT64-T",NULL},
{KEY_ "LONG",NULL},
{KEY_ "LONG-DOUBLE",NULL},
{KEY_ "LONG-LONG",NULL},
{KEY_ "POINTER-SELF",NULL},
{KEY_ "POINTER-VOID",NULL},

8
src/cmp/cmpc-machine.lsp
View file

@ -19,6 +19,7 @@
(defconstant +representation-types+
'(;; These types can be used by ECL to unbox data
;; They are sorted from the most specific, to the least specific one.
;; All functions must be declared in externa.h (not internal.h) header file.
(:byte .
#1=((signed-byte 8) "int8_t" "ecl_make_int8_t" "ecl_to_int8_t" "ecl_fixnum"))
(:unsigned-byte .
@ -34,6 +35,9 @@
(:float single-float "float" "ecl_make_single_float" "ecl_to_float" "ecl_single_float")
(:double double-float "double" "ecl_make_double_float" "ecl_to_double" "ecl_double_float")
(:long-double long-float "long double" "ecl_make_long_float" "ecl_to_long_double" "ecl_long_float")
(:csfloat si::complex-single-float "_Complex float" "ecl_make_csfloat" "ecl_to_csfloat" "ecl_csfloat")
(:cdfloat si::complex-double-float "_Complex double" "ecl_make_cdfloat" "ecl_to_cdfloat" "ecl_cdfloat")
(:clfloat si::complex-long-float "_Complex long double" "ecl_make_clfloat" "ecl_to_clfloat" "ecl_clfloat")
(:unsigned-char base-char "unsigned char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE")
(:char base-char "char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE")
(:wchar character "ecl_character" "CODE_CHAR" "ecl_char_code" "CHAR_CODE")
@ -96,7 +100,9 @@
#+:sse2 (:double-sse-pack . nil)
#+:sse2 (:int-sse-pack . nil)
#+:long-float (:long-double . nil)
))
#+complex-float (:csfloat . nil)
#+complex-float (:cdfloat . nil)
#+complex-float (:clfloat . nil)))
(defconstant +all-machines-c-types+
'((:object)

5
src/cmp/cmpcbk.lsp
View file

@ -73,6 +73,11 @@
(:object . "ECL_FFI_OBJECT")
(:float . "ECL_FFI_FLOAT")
(:double . "ECL_FFI_DOUBLE")
(:long-double . "ECL_FFI_LONG_DOUBLE")
;; complex floats
(:csfloat . "ECL_FFI_CSFLOAT")
(:cdfloat . "ECL_FFI_CDFLOAT")
(:clfloat . "ECL_FFI_CLFLOAT")
(:void . "ECL_FFI_VOID")))
(defun foreign-elt-type-code (type)

16
src/cmp/cmpct.lsp
View file

@ -21,11 +21,12 @@
(cond
((let ((x (assoc val *optimizable-constants*)))
(when x
(pushnew "#include <float.h>" *clines-string-list*)
(setf x (cdr x))
(if (listp x)
(c1expr x)
x))))
(pushnew "#include <float.h>" *clines-string-list*)
(pushnew "#include <complex.h>" *clines-string-list*)
(setf x (cdr x))
(if (listp x)
(c1expr x)
x))))
((eq val nil) (c1nil))
((eq val t) (c1t))
((sys::fixnump val)
@ -88,7 +89,10 @@
(loc-type (case type
(single-float 'single-float-value)
(double-float 'double-float-value)
(long-float 'long-float-value)))
(long-float 'long-float-value)
(si:complex-single-float 'csfloat-value)
(si:complex-double-float 'cdfloat-value)
(si:complex-long-float 'clfloat-value)))
(location (make-vv :location c-value :value value)))
(cons value (make-c1form* 'LOCATION :type type
:args (list loc-type value location)))))

8
src/cmp/cmpexit.lsp
View file

@ -127,8 +127,9 @@
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return value0;")))
(return))
((RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT
RETURN-SINGLE-FLOAT RETURN-OBJECT)
((RETURN-FIXNUM RETURN-CHARACTER RETURN-OBJECT
RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT RETURN-LONG-FLOAT
RETURN-CSFLOAT RETURN-CSFLOAT RETURN-CSFLOAT)
(when (eq *exit* ue)
;; *destination* must be RETURN-FIXNUM
(setq loc (list 'COERCE-LOC
@ -136,6 +137,9 @@
RETURN-CHARACTER :char
RETURN-SINGLE-FLOAT :float
RETURN-DOUBLE-FLOAT :double
RETURN-CSFLOAT :csfloat
RETURN-CDFLOAT :cdfloat
RETURN-CLFLOAT :clfloat
RETURN-OBJECT :object)
ue)
loc))

22
src/cmp/cmpffi.lsp
View file

@ -79,7 +79,10 @@
(when (and (consp loc) (member (first loc)
'(single-float-value
double-float-value
long-float-value)))
long-float-value
csfloat-value
cdfloat-value
clfloat-value)))
(wt (third loc)) ;; VV index
(return-from wt-to-object-conversion))
(let ((record (rep-type-record loc-rep-type)))
@ -127,6 +130,9 @@
(DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT)
(SINGLE-FLOAT-VALUE 'SINGLE-FLOAT)
(LONG-FLOAT-VALUE 'LONG-FLOAT)
(CSFLOAT-VALUE 'SI:COMPLEX-SINGLE-FLOAT)
(CDFLOAT-VALUE 'SI:COMPLEX-DOUBLE-FLOAT)
(CLFLOAT-VALUE 'SI:COMPLEX-LONG-FLOAT)
(C-INLINE (let ((type (first (second loc))))
(cond ((and (consp type) (eq (first type) 'VALUES)) T)
((lisp-type-p type) type)
@ -151,6 +157,9 @@
(DOUBLE-FLOAT-VALUE :double)
(SINGLE-FLOAT-VALUE :float)
(LONG-FLOAT-VALUE :long-double)
(CSFLOAT-VALUE :csfloat)
(CDFLOAT-VALUE :cdfloat)
(CLFLOAT-VALUE :clfloat)
(C-INLINE (let ((type (first (second loc))))
(cond ((and (consp type) (eq (first type) 'VALUES)) :object)
((lisp-type-p type) (lisp-type->rep-type type))
@ -199,6 +208,17 @@
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
(t
(coercion-error))))
((:csfloat :cdfloat :clfloat)
(cond
((c-number-rep-type-p loc-rep-type)
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
((eq loc-rep-type :object)
;; We relax the check a bit, because it is valid in C to coerce
;; between COMPLEX floats of different types.
(ensure-valid-object-type 'SI:COMPLEX-FLOAT)
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
(t
(coercion-error))))
((:bool)
(cond
((c-number-rep-type-p loc-rep-type)

9
src/cmp/cmpglobals.lsp
View file

@ -142,8 +142,8 @@ running the compiler. It may be updated by running ")
;;; *last-label* holds the label# of the last used label.
;;; *exit* holds an 'exit', which is
;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
;; RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or
;; RETURN-OBJECT).
;; RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT,
;; RETURN-CSFLOAT, RETURN-CDFLOAT, RETURN-CLFLOAT or RETURN-OBJECT).
;;; *unwind-exit* holds a list consisting of:
;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
;; JUMP, BDS-BIND (each pushed for a single special binding), or a
@ -281,6 +281,11 @@ lines are inserted, but the order is preserved")
;;; | ( 'LOAD-TIME-VALUE' vv )
;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...).
;;; FIXME: global-entries mechanism seems to be completely abandoned
;;; (always NIL). Either remove compiler code which uses it and remove
;;; variable itself or properly document it and use where
;;; applicable. -- jd 2019-05-07
(defvar *global-entries* nil)
(defvar *global-macros* nil)

9
src/cmp/cmploc.lsp
View file

@ -41,6 +41,9 @@
;;; ( LONG-FLOAT-VALUE long-float-value vv )
;;; ( DOUBLE-FLOAT-VALUE double-float-value vv )
;;; ( SINGLE-FLOAT-VALUE single-float-value vv )
;;; ( CSFLOAT-VALUE csfloat-value vv )
;;; ( CDFLOAT-VALUE cdfloat-value vv )
;;; ( CLFLOAT-VALUE clfloat-value vv )
;;; ( STACK-POINTER index ) retrieve a value from the stack
;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index )
;;; ( THE type location )
@ -92,6 +95,9 @@
((member (setf loc (car loc))
'(VV VV-TEMP FIXNUM-VALUE CHARACTER-VALUE
DOUBLE-FLOAT-VALUE SINGLE-FLOAT-VALUE #+long-float LONG-FLOAT-VALUE
#+complex-float CSFLOAT-VALUE
#+complex-float CDFLOAT-VALUE
#+complex-float CLFLOAT-VALUE
KEYVARS))
t)
(t
@ -122,7 +128,8 @@
(loc-immediate-value-p (third loc)))
((member (first loc)
'(fixnum-value long-float-value
double-float-value single-float-value))
double-float-value single-float-value
csfloat-value cdfloat-value clfloat-value))
(values t (second loc)))
((eq (first loc) 'character-value)
(values t (code-char (second loc))))

3
src/cmp/cmptables.lsp
View file

@ -187,6 +187,9 @@
(double-float-value . wt-number)
(single-float-value . wt-number)
(short-float-value . wt-number)
(csfloat-value . wt-number)
(cdfloat-value . wt-number)
(clfloat-value . wt-number)
(character-value . wt-character)
(value . wt-value)
(keyvars . wt-keyvars)

19
src/cmp/cmptop.lsp
View file

@ -476,14 +476,13 @@
(when (compiler-check-args)
(wt-nl "_ecl_check_narg(" (length arg-types) ");"))
(wt-nl "cl_env_copy->nvalues = 1;")
(wt-nl "return " (case return-type
(FIXNUM "ecl_make_fixnum")
(CHARACTER "CODE_CHAR")
(DOUBLE-FLOAT "ecl_make_double_float")
(SINGLE-FLOAT "ecl_make_single_float")
#+long-float
(LONG-FLOAT "ecl_make_long_float")
(otherwise ""))
(wt-nl "return " (ecase return-type
(FIXNUM "ecl_make_fixnum")
(CHARACTER "CODE_CHAR")
(DOUBLE-FLOAT "ecl_make_double_float")
(SINGLE-FLOAT "ecl_make_single_float")
#+long-float
(LONG-FLOAT "ecl_make_long_float"))
"(LI" cfun "(")
(do ((types arg-types (cdr types))
(n 1 (1+ n)))
@ -610,6 +609,10 @@
(:char . "_ecl_base_char_loc")
(:float . "_ecl_float_loc")
(:double . "_ecl_double_loc")
#+long-float (:long-double . "_ecl_long_double_loc")
#+complex-float (:csfloat . "_ecl_csfloat_loc")
#+complex-float (:cdfloat . "_ecl_cdfloat_loc")
#+complex-float (:clfloat . "_ecl_clfloat_loc")
#+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc")
#+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc")
#+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc")

27
src/cmp/cmpwt.lsp
View file

@ -283,6 +283,27 @@
"ecl_def_ct_complex(~A,&~A_data,&~A_data,static,const);"
name name-real name-imag)))
#+complex-float
(defun static-csfloat-builder (name value stream)
(let* ((*read-default-float-format* 'single-float)
(*print-readably* t))
(format stream "ecl_def_ct_csfloat(~A,(~S + I*~S),static,const);"
name (realpart value) (imagpart value) stream)))
#+complex-float
(defun static-cdfloat-builder (name value stream)
(let* ((*read-default-float-format* 'double-float)
(*print-readably* t))
(format stream "ecl_def_ct_cdfloat(~A,(~S + I*~S),static,const);"
name (realpart value) (imagpart value) stream)))
#+complex-float
(defun static-clfloat-builder (name value stream)
(let* ((*read-default-float-format* 'long-float)
(*print-readably* t))
(format stream "ecl_def_ct_clfloat(~A,(~SL + I*~SL),static,const);"
name (realpart value) (imagpart value) stream)))
#+sse2
(defun static-sse-pack-builder (name value stream)
(let* ((bytes (ext:sse-pack-to-vector value '(unsigned-byte 8)))
@ -311,6 +332,12 @@
(long-float (and (not (ext:float-nan-p object))
(not (ext:float-infinity-p object))
#'static-long-float-builder))
#+complex-float
(si:complex-single-float #'static-csfloat-builder)
#+complex-float
(si:complex-double-float #'static-cdfloat-builder)
#+complex-float
(si:complex-long-float #'static-clfloat-builder)
(complex (and (static-constant-expression (realpart object))
(static-constant-expression (imagpart object))
#'static-complex-builder))

8
src/h/ecl-cmp.h
View file

@ -45,6 +45,14 @@ enum ecl_locative_type {
_ecl_uni_char_loc,
_ecl_float_loc,
_ecl_double_loc
#ifdef ECL_LONG_FLOAT
, _ecl_long_double_loc
#endif
#ifdef ECL_COMPLEX_FLOAT
, _ecl_csfloat_loc
, _ecl_cdfloat_loc
, _ecl_clfloat_loc
#endif
#ifdef ECL_SSE2
, _ecl_int_sse_pack_loc
, _ecl_float_sse_pack_loc

9
src/h/ecl-inl.h
View file

@ -5,6 +5,11 @@
#ifndef ECL_ECL_INL_H
#define ECL_ECL_INL_H
#ifdef ECL_COMPLEX_FLOAT
/* We need this include for the constant I. */
#include <complex.h>
#endif
/*
* Loops over a proper list. Complains on circularity
*/
@ -139,9 +144,9 @@
#endif
#define ecl_def_ct_vector(name,type,raw,len,static,const) \
static const struct ecl_vector name ## _data = { \
static const struct ecl_vector name ## _data = { \
(int8_t)t_vector, 0, (type), 0, \
ECL_NIL, (cl_index)(len), (cl_index)(len), \
ECL_NIL, (cl_index)(len), (cl_index)(len), \
ecl_cast_ptr(cl_object*,raw), 0 }; \
static const cl_object name = (cl_object)(& name ## _data)

16
src/h/object.h
View file

@ -813,6 +813,14 @@ enum ecl_ffi_tag {
ECL_FFI_OBJECT,
ECL_FFI_FLOAT,
ECL_FFI_DOUBLE,
#ifdef ECL_LONG_FLOAT
ECL_FFI_LONG_DOUBLE,
#endif
#ifdef ECL_COMPLEX_FLOAT
ECL_FFI_CSFLOAT,
ECL_FFI_CDFLOAT,
ECL_FFI_CLFLOAT,
#endif
ECL_FFI_VOID
};
@ -853,6 +861,14 @@ union ecl_ffi_values {
cl_object o;
float f;
double d;
#ifdef ECL_LONG_FLOAT
long double lf;
#endif
#ifdef ECL_COMPLEX_FLOAT
float _Complex csf;
double _Complex cdf;
long double _Complex clf;
#endif
};
enum ecl_ffi_calling_convention {

24
src/lsp/top.lsp
View file

@ -911,6 +911,30 @@ Use special code 0 to cancel this operation.")
output = ecl_make_double_float(*p);
break;
}
#ifdef ECL_LONG_FLOAT
case _ecl_long_double_loc: {
long double *p = (long double*)value;
output = ecl_make_long_float(*p);
break;
}
#endif
#ifdef ECL_COMPLEX_FLOAT
case _ecl_csfloat_loc: {
_Complex float *p = (_Complex float*)value;
output = ecl_make_csfloat(*p);
break;
}
case _ecl_cdfloat_loc: {
_Complex double *p = (_Complex double*)value;
output = ecl_make_cdfloat(*p);
break;
}
case _ecl_clfloat_loc: {
_Complex long double *p = (_Complex long double*)value;
output = ecl_make_clfloat(*p);
break;
}
#endif
#ifdef ECL_SSE2
case _ecl_int_sse_pack_loc: {
__m128i *p = (__m128i*)value;