Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Initial half and quarter precision uniform vectors.

Browse source 
Quarter precision is 1.5.2 format.
Used to implement f16-storage-class and f8-storage-class.
Can be disabled at compile time.
This commit is contained in:
Alex Shinn 2024-05-24 19:04:44 +09:00
parent e4568bd419
commit f60298b707
13 changed files with 544 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
include/chibi/features.h
View file

@ -718,6 +718,10 @@
#define SEXP_USE_UNIFORM_VECTOR_LITERALS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
#define SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_BYTEVECTOR_LITERALS
#define SEXP_USE_BYTEVECTOR_LITERALS SEXP_USE_UNIFORM_VECTOR_LITERALS
#endif

24
include/chibi/sexp.h
View file

@ -774,6 +774,7 @@ void* sexp_alloc(sexp ctx, size_t size);
#define sexp_markedp(x) ((x)->markedp)
#define sexp_flags(x) ((x)->flags)
#define sexp_immutablep(x) ((x)->immutablep)
#define sexp_mutablep(x) (!(x)->immutablep)
#define sexp_freep(x) ((x)->freep)
#define sexp_brokenp(x) ((x)->brokenp)
#define sexp_pointer_magic(x) ((x)->magic)
@ -792,11 +793,12 @@ void* sexp_alloc(sexp ctx, size_t size);
#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b)))
#if SEXP_USE_IMMEDIATE_FLONUMS
union sexp_flonum_conv {
float flonum;
unsigned int bits;
};
#if SEXP_USE_IMMEDIATE_FLONUMS
#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_IFLONUM_TAG)
SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x);
#if SEXP_64_BIT
@ -877,6 +879,8 @@ SEXP_API sexp sexp_make_flonum(sexp ctx, double f);
#define sexp_s32vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S32)
#define sexp_u64vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_U64)
#define sexp_s64vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_S64)
#define sexp_f8vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F8)
#define sexp_f16vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F16)
#define sexp_f32vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F32)
#define sexp_f64vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_F64)
#define sexp_c64vectorp(x) (sexp_uvectorp(x) && sexp_uvector_type(x)==SEXP_C64)
@ -892,6 +896,8 @@ SEXP_API sexp sexp_make_flonum(sexp ctx, double f);
#define sexp_s32vectorp(x) (sexp_vectorp(x))
#define sexp_u64vectorp(x) (sexp_vectorp(x))
#define sexp_s64vectorp(x) (sexp_vectorp(x))
#define sexp_f8vectorp(x) (sexp_vectorp(x))
#define sexp_f16vectorp(x) (sexp_vectorp(x))
#define sexp_f32vectorp(x) (sexp_vectorp(x))
#define sexp_f64vectorp(x) (sexp_vectorp(x))
#define sexp_c64vectorp(x) (sexp_vectorp(x))
@ -1118,6 +1124,13 @@ SEXP_API unsigned long long sexp_bignum_to_uint(sexp x);
#define sexp_flonum_eqv(x, y) (sexp_flonum_value(x) == sexp_flonum_value(y))
#endif
#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
SEXP_API double sexp_quarter_to_double(unsigned char q);
SEXP_API unsigned char sexp_double_to_quarter(double f);
SEXP_API double sexp_half_to_double(unsigned short x);
SEXP_API unsigned short sexp_double_to_half(double x);
#endif
/*************************** field accessors **************************/
#if SEXP_USE_SAFE_ACCESSORS
@ -1164,8 +1177,8 @@ SEXP_API unsigned long long sexp_bignum_to_uint(sexp x);
#define sexp_bytes_maybe_null_data(x) (sexp_not(x) ? NULL : sexp_bytes_data(x))
static const unsigned char sexp_uvector_sizes[] = {
0, 1, 8, 8, 16, 16, 32, 32, 64, 64, 32, 64, 64, 128};
static const unsigned char sexp_uvector_chars[] = "#ususususuffcc";
0, 1, 8, 8, 16, 16, 32, 32, 64, 64, 32, 64, 64, 128, 8, 16};
static const unsigned char sexp_uvector_chars[] = "#ususususuffccff";
enum sexp_uniform_vector_type {
SEXP_NOT_A_UNIFORM_TYPE,
@ -1181,7 +1194,10 @@ enum sexp_uniform_vector_type {
SEXP_F32,
SEXP_F64,
SEXP_C64,
SEXP_C128
SEXP_C128,
SEXP_F8,
SEXP_F16,
SEXP_END_OF_UNIFORM_TYPES
};
#define sexp_uvector_freep(x) (sexp_freep(x))

17
lib/srfi/160/base.sld
View file

@ -1,7 +1,8 @@
(define-library (srfi 160 base)
(import (scheme base)
(only (chibi) list->uvector make-uvector))
(only (chibi) list->uvector make-uvector)
(srfi 160 prims))
(export
;;
make-u1vector u1vector u1? u1vector?
@ -40,6 +41,14 @@
s64vector-ref s64vector-set! s64vector-length
s64vector->list list->s64vector
;;
;; make-f8vector f8vector f8? f8vector?
;; f8vector-ref f8vector-set! f8vector-length
;; f8vector->list list->f8vector
;;
;; make-f16vector f16vector f16? f16vector?
;; f16vector-ref f16vector-set! f16vector-length
;; f16vector->list list->f16vector
;;
make-f32vector f32vector f32? f32vector?
f32vector-ref f32vector-set! f32vector-length
f32vector->list list->f32vector
@ -56,12 +65,6 @@
c128vector-ref c128vector-set! c128vector-length
c128vector->list list->c128vector
)
(cond-expand
(uvector
(include-shared "uvprims"))
(else
(begin
)))
(begin
(define u8vector? bytevector?)
(define u8vector-ref bytevector-u8-ref)

96
lib/srfi/160/f16.sld Normal file
View file

@ -0,0 +1,96 @@
(define-library (srfi 160 f16)
(export
make-f16vector
f16vector
list->f16vector
f16vector->list
f16?
f16vector?
f16vector-ref
f16vector-set!
f16vector-length
(rename uvector-unfold f16vector-unfold)
(rename uvector-unfold-right f16vector-unfold-right)
(rename vector-copy f16vector-copy)
(rename vector-reverse-copy f16vector-reverse-copy)
(rename vector-append f16vector-append)
(rename vector-concatenate f16vector-concatenate)
(rename vector-append-subvectors f16vector-append-subvectors)
(rename vector-empty? f16vector-empty?)
(rename vector= f16vector=)
(rename vector-take f16vector-take)
(rename vector-take-right f16vector-take-right)
(rename vector-drop f16vector-drop)
(rename vector-drop-right f16vector-drop-right)
(rename vector-segment f16vector-segment)
(rename vector-fold f16vector-fold)
(rename vector-fold-right f16vector-fold-right)
(rename vector-map f16vector-map)
(rename vector-map! f16vector-map!)
(rename vector-for-each f16vector-for-each)
(rename vector-count f16vector-count)
(rename vector-cumulate f16vector-cumulate)
(rename vector-take-while f16vector-take-while)
(rename vector-take-while-right f16vector-take-while-right)
(rename vector-drop-while f16vector-drop-while)
(rename vector-drop-while-right f16vector-drop-while-right)
(rename vector-index f16vector-index)
(rename vector-index-right f16vector-index-right)
(rename vector-skip f16vector-skip)
(rename vector-skip-right f16vector-skip-right)
(rename vector-binary-search f16vector-binary-search)
(rename vector-any f16vector-any)
(rename vector-every f16vector-every)
(rename vector-partition f16vector-partition)
(rename vector-filter f16vector-filter)
(rename vector-remove f16vector-remove)
(rename vector-swap! f16vector-swap!)
(rename vector-fill! f16vector-fill!)
(rename vector-reverse! f16vector-reverse!)
(rename vector-copy! f16vector-copy!)
(rename vector-reverse-copy! f16vector-reverse-copy!)
(rename reverse-vector->list reverse-f16vector->list)
(rename reverse-list->vector reverse-list->f16vector)
(rename uvector->vector f16vector->vector)
(rename vector->uvector vector->f16vector)
(rename make-vector-generator make-f16vector-generator)
(rename write-vector write-f16vector))
(import (except (scheme base)
vector-append vector-copy vector-copy!
vector-map vector-for-each)
(scheme write)
(srfi 160 base)
(srfi 160 prims)
(rename (only (chibi) list->uvector make-uvector)
(list->uvector list->uniform-vector)
(make-uvector make-uniform-vector)))
(begin
(define (f16? x) (and (real? x) (inexact? x)))
(define f16vector-length uvector-length)
(define (make-f16vector len . o)
(let ((res (make-uniform-vector SEXP_F16 len)))
(if (and (pair? o) (not (zero? (car o))))
(do ((i 0 (+ i 1)))
((>= i len))
(f16vector-set! res i (car o))))
res))
(define (f16vector->list uv . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(f16vector-length uv))))
(do ((i (- end 1) (- i 1))
(res '() (cons (f16vector-ref uv i) res)))
((< i start) res))))
(define (list->f16vector ls) (list->uniform-vector SEXP_F16 ls))
(define (f16vector . args) (list->f16vector args))
(define uvector? f16vector?)
(define make-uvector make-f16vector)
(define vector f16vector)
(define uvector->list f16vector->list)
(define list->uvector list->f16vector)
(define uvector-length f16vector-length)
(define uvector-ref f16vector-ref)
(define uvector-set! f16vector-set!))
(include "uvector.scm"))

96
lib/srfi/160/f8.sld Normal file
View file

@ -0,0 +1,96 @@
(define-library (srfi 160 f8)
(export
make-f8vector
f8vector
list->f8vector
f8vector->list
f8?
f8vector?
f8vector-ref
f8vector-set!
f8vector-length
(rename uvector-unfold f8vector-unfold)
(rename uvector-unfold-right f8vector-unfold-right)
(rename vector-copy f8vector-copy)
(rename vector-reverse-copy f8vector-reverse-copy)
(rename vector-append f8vector-append)
(rename vector-concatenate f8vector-concatenate)
(rename vector-append-subvectors f8vector-append-subvectors)
(rename vector-empty? f8vector-empty?)
(rename vector= f8vector=)
(rename vector-take f8vector-take)
(rename vector-take-right f8vector-take-right)
(rename vector-drop f8vector-drop)
(rename vector-drop-right f8vector-drop-right)
(rename vector-segment f8vector-segment)
(rename vector-fold f8vector-fold)
(rename vector-fold-right f8vector-fold-right)
(rename vector-map f8vector-map)
(rename vector-map! f8vector-map!)
(rename vector-for-each f8vector-for-each)
(rename vector-count f8vector-count)
(rename vector-cumulate f8vector-cumulate)
(rename vector-take-while f8vector-take-while)
(rename vector-take-while-right f8vector-take-while-right)
(rename vector-drop-while f8vector-drop-while)
(rename vector-drop-while-right f8vector-drop-while-right)
(rename vector-index f8vector-index)
(rename vector-index-right f8vector-index-right)
(rename vector-skip f8vector-skip)
(rename vector-skip-right f8vector-skip-right)
(rename vector-binary-search f8vector-binary-search)
(rename vector-any f8vector-any)
(rename vector-every f8vector-every)
(rename vector-partition f8vector-partition)
(rename vector-filter f8vector-filter)
(rename vector-remove f8vector-remove)
(rename vector-swap! f8vector-swap!)
(rename vector-fill! f8vector-fill!)
(rename vector-reverse! f8vector-reverse!)
(rename vector-copy! f8vector-copy!)
(rename vector-reverse-copy! f8vector-reverse-copy!)
(rename reverse-vector->list reverse-f8vector->list)
(rename reverse-list->vector reverse-list->f8vector)
(rename uvector->vector f8vector->vector)
(rename vector->uvector vector->f8vector)
(rename make-vector-generator make-f8vector-generator)
(rename write-vector write-f8vector))
(import (except (scheme base)
vector-append vector-copy vector-copy!
vector-map vector-for-each)
(scheme write)
(srfi 160 base)
(srfi 160 prims)
(rename (only (chibi) list->uvector make-uvector)
(list->uvector list->uniform-vector)
(make-uvector make-uniform-vector)))
(begin
(define (f8? x) (and (real? x) (inexact? x)))
(define f8vector-length uvector-length)
(define (make-f8vector len . o)
(let ((res (make-uniform-vector SEXP_F8 len)))
(if (and (pair? o) (not (zero? (car o))))
(do ((i 0 (+ i 1)))
((>= i len))
(f8vector-set! res i (car o))))
res))
(define (f8vector->list uv . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(f8vector-length uv))))
(do ((i (- end 1) (- i 1))
(res '() (cons (f8vector-ref uv i) res)))
((< i start) res))))
(define (list->f8vector ls) (list->uniform-vector SEXP_F8 ls))
(define (f8vector . args) (list->f8vector args))
(define uvector? f8vector?)
(define make-uvector make-f8vector)
(define vector f8vector)
(define uvector->list f8vector->list)
(define list->uvector list->f8vector)
(define uvector-length f8vector-length)
(define uvector-ref f8vector-ref)
(define uvector-set! f8vector-set!))
(include "uvector.scm"))

88
lib/srfi/160/mini-test.sld Normal file
View file

@ -0,0 +1,88 @@
(define-library (srfi 160 mini-test)
(import (scheme base)
(srfi 160 base) (srfi 160 f8) (srfi 160 f16)
(chibi test))
(export run-tests)
(begin
(define (run-tests)
(test-begin "srfi-160: half and quarter precision")
(test-group "f8"
(define f8v '#f8(0 1 2 3 4 5 6 7 8))
(test '#f8(0 1 2 3 4) (f8vector 0 1 2 3 4))
(test '#f8(0 1 2 3 4 5 6 7 8 9)
(f8vector-unfold (lambda (i x) (values x (+ x 1))) 10 0.0))
(test '#f8(0 1 2 3 4 5 6)
(f8vector-unfold (lambda (i x) (values (inexact i) (+ x 1))) 7 0.0))
(test f8v (f8vector-copy f8v))
(test-assert (not (eqv? f8v (f8vector-copy f8v))))
(test '#f8(6 7 8) (f8vector-copy f8v 6))
(test '#f8(3 4 5) (f8vector-copy f8v 3 6))
(test '#f8(4 3 1) (f8vector-reverse-copy (f8vector 1 3 4)))
(test '#f8(1 2 3 4) (f8vector-reverse-copy '#f8(5 4 3 2 1 0) 1 5))
(test '(#f8(#x01 #x02) #f8(#x03 #x04))
(f8vector-segment #f8(1 2 3 4) 2))
(test '#f8(0 1) (f8vector-append '#f8(0) '#f8(1)))
(test '#f8(0 1 2 3) (f8vector-append '#f8(0) '#f8(1 2 3)))
(test '#f8(0 1 2 3) (f8vector-concatenate '(#f8(0 1) #f8(2 3))))
(test '#f8(0 1 6 7)
(f8vector-append-subvectors '#f8(0 1 2 3 4) 0 2 '#f8(4 5 6 7 8) 2 4))
(test '#f8(1 2)
(vector->f8vector '#(0 1 2 3) 1 3))
(test '#(1.0 2.0)
(f8vector->vector '#f8(0 1 2 3) 1 3))
;; round trip accuracy
(let ((v (make-f8vector 1)))
(f8vector-set! v 0 +nan.0)
(test "+nan.0" (number->string (f8vector-ref v 0)))
(for-each
(lambda (x)
(f8vector-set! v 0 (car x))
(test (cadr x) (f8vector-ref v 0))
(f8vector-set! v 0 (- (car x)))
(test (- (cadr x)) (f8vector-ref v 0))
)
'((0. 0.)
(0.0001 0.0001068115234375)
(#i1/3 0.3125)
(0.5 0.5)
(1. 1.)
(7. 7.)
(8. 8.)
(9. 8.)
(10. 10.)
(45. 48.)
(45000. 40960.)
(999999.0 57344.0)
(+inf.0 +inf.0)
)))
)
(test-group "f16"
(define f16v '#f16(0 1 2 3 4 5 6 7 8))
(test '#f16(0 1 2 3 4) (f16vector 0 1 2 3 4))
(test '#f16(0 1 2 3 4 5 6 7 8 9)
(f16vector-unfold (lambda (i x) (values x (+ x 1))) 10 0.0))
(test '#f16(0 1 2 3 4 5 6)
(f16vector-unfold (lambda (i x) (values (inexact i) (+ x 1))) 7 0.0))
(test f16v (f16vector-copy f16v))
(test-assert (not (eqv? f16v (f16vector-copy f16v))))
(test '#f16(6 7 8) (f16vector-copy f16v 6))
(test '#f16(3 4 5) (f16vector-copy f16v 3 6))
(test '#f16(4 3 1) (f16vector-reverse-copy (f16vector 1 3 4)))
(test '#f16(1 2 3 4) (f16vector-reverse-copy '#f16(5 4 3 2 1 0) 1 5))
(test '(#f16(#x01 #x02) #f16(#x03 #x04))
(f16vector-segment #f16(1 2 3 4) 2))
(test '#f16(0 1) (f16vector-append '#f16(0) '#f16(1)))
(test '#f16(0 1 2 3) (f16vector-append '#f16(0) '#f16(1 2 3)))
(test '#f16(0 1 2 3) (f16vector-concatenate '(#f16(0 1) #f16(2 3))))
(test '#f16(0 1 6 7)
(f16vector-append-subvectors '#f16(0 1 2 3 4) 0 2 '#f16(4 5 6 7 8) 2 4))
(test '#f16(1 2)
(vector->f16vector '#(0 1 2 3) 1 3))
(test '#(1.0 2.0)
(f16vector->vector '#f16(0 1 2 3) 1 3))
)
(test-end))))

25
lib/srfi/160/prims.sld Normal file
View file

@ -0,0 +1,25 @@
(define-library (srfi 160 prims)
(export
uvector-length
SEXP_U1 SEXP_S8 SEXP_U8 SEXP_S16 SEXP_U16
SEXP_S32 SEXP_U32 SEXP_S64 SEXP_U64
SEXP_F32 SEXP_F64 SEXP_F8 SEXP_F16
SEXP_C64 SEXP_C128
u1vector? u1vector-ref u1vector-set!
;; u8vector? u8vector-ref u8vector-set!
s8vector? s8vector-ref s8vector-set!
u16vector? u16vector-ref u16vector-set!
s16vector? s16vector-ref s16vector-set!
u32vector? u32vector-ref u32vector-set!
s32vector? s32vector-ref s32vector-set!
u64vector? u64vector-ref u64vector-set!
s64vector? s64vector-ref s64vector-set!
f8vector? f8vector-ref f8vector-set!
f16vector? f16vector-ref f16vector-set!
f32vector? f32vector-ref f32vector-set!
f64vector? f64vector-ref f64vector-set!
c64vector? c64vector-ref c64vector-set!
c128vector? c128vector-ref c128vector-set!
)
(include-shared "uvprims"))

62
lib/srfi/160/uvprims.stub
View file

@ -14,9 +14,12 @@
SEXP_F32
SEXP_F64
SEXP_C64
SEXP_C128)
SEXP_C128
SEXP_F8
SEXP_F16
)
(c-declare "
(c-declare "
int uvector_of(sexp uv, int etype) {
return sexp_uvectorp(uv) && sexp_uvector_type(uv) == etype;
}
@ -77,6 +80,20 @@ void s64vector_set(int64_t* uv, int i, int64_t v) {
uv[i] = v;
}
float f8vector_ref(unsigned char* uv, int i) {
return sexp_quarter_to_double(uv[i]);
}
void f8vector_set(unsigned char* uv, int i, double v) {
uv[i] = sexp_double_to_quarter(v);
}
double f16vector_ref(unsigned short* uv, int i) {
return sexp_half_to_double(uv[i]);
}
void f16vector_set(unsigned short* uv, int i, double v) {
uv[i] = sexp_double_to_half(v);
}
float f32vector_ref(float* uv, int i) {
return uv[i];
}
@ -130,6 +147,8 @@ void c128vector_set(sexp ctx, double* uv, int i, sexp v) {
(define-c boolean (s32vector? "uvector_of") (sexp (value SEXP_S32 int)))
(define-c boolean (u64vector? "uvector_of") (sexp (value SEXP_U64 int)))
(define-c boolean (s64vector? "uvector_of") (sexp (value SEXP_S64 int)))
(define-c boolean (f8vector? "uvector_of") (sexp (value SEXP_F8 int)))
(define-c boolean (f16vector? "uvector_of") (sexp (value SEXP_F16 int)))
(define-c boolean (f32vector? "uvector_of") (sexp (value SEXP_F32 int)))
(define-c boolean (f64vector? "uvector_of") (sexp (value SEXP_F64 int)))
(define-c boolean (c64vector? "uvector_of") (sexp (value SEXP_C64 int)))
@ -138,66 +157,83 @@ void c128vector_set(sexp ctx, double* uv, int i, sexp v) {
(define-c int u1vector-ref (sexp int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u1vector-set! "u1vector_set") (sexp int int)
(assert (< -1 arg1 (uvector-length arg0))
(assert (mutable? arg0)
(< -1 arg1 (uvector-length arg0))
(< -1 arg2 (expt 2 1))))
(define-c signed-char s8vector-ref (s8vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (s8vector-set! "s8vector_set") (s8vector int signed-char)
(assert (< -1 arg1 (uvector-length arg0))
(assert (mutable? arg0)
(< -1 arg1 (uvector-length arg0))
(<= (- (expt 2 7)) arg2 (- (expt 2 7) 1))))
(define-c unsigned-short u16vector-ref (u16vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u16vector-set! "u16vector_set") (u16vector int unsigned-short)
(assert (< -1 arg1 (uvector-length arg0))
(assert (mutable? arg0)
(< -1 arg1 (uvector-length arg0))
(<= 0 arg2 (expt 2 16))))
(define-c short s16vector-ref (s16vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (s16vector-set! "s16vector_set") (s16vector int short)
(assert (< -1 arg1 (uvector-length arg0))
(assert (mutable? arg0)
(< -1 arg1 (uvector-length arg0))
(<= (- (expt 2 15)) arg2 (- (expt 2 15) 1))))
(define-c unsigned-int u32vector-ref (u32vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u32vector-set! "u32vector_set") (u32vector int unsigned-int)
(assert (< -1 arg1 (uvector-length arg0))
(assert (mutable? arg0)
(< -1 arg1 (uvector-length arg0))
(<= 0 arg2 (expt 2 32))))
(define-c int32_t s32vector-ref (s32vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (s32vector-set! "s32vector_set") (s32vector int int32_t)
(assert (< -1 arg1 (uvector-length arg0))
(assert (mutable? arg0)
(< -1 arg1 (uvector-length arg0))
(<= (- (expt 2 31)) arg2 (- (expt 2 31) 1))))
(define-c uint64_t u64vector-ref (u64vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u64vector-set! "u64vector_set") (u64vector int uint64_t)
(assert (< -1 arg1 (uvector-length arg0))
(assert (mutable? arg0)
(< -1 arg1 (uvector-length arg0))
(<= 0 arg2)))
(define-c int64_t s64vector-ref (s64vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (s64vector-set! "s64vector_set") (s64vector int int64_t)
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
(define-c double f8vector-ref (f8vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (f8vector-set! "f8vector_set") (f8vector int double)
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
(define-c double f16vector-ref (f16vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (f16vector-set! "f16vector_set") (f16vector int double)
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
(define-c float f32vector-ref (f32vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (f32vector-set! "f32vector_set") (f32vector int float)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
(define-c double f64vector-ref (f64vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (f64vector-set! "f64vector_set") (f64vector int double)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (mutable? arg0) (< -1 arg1 (uvector-length arg0))))
(define-c sexp c64vector-ref ((value ctx sexp) c64vector int)
(assert (< -1 arg2 (uvector-length arg1))))
(define-c void (c64vector-set! "c64vector_set") ((value ctx sexp) c64vector int sexp)
(assert (< -1 arg2 (uvector-length arg1))))
(assert (mutable? arg1) (< -1 arg2 (uvector-length arg1))))
(define-c sexp c128vector-ref ((value ctx sexp) c128vector int)
(assert (< -1 arg2 (uvector-length arg1))))
(define-c void (c128vector-set! "c128vector_set") ((value ctx sexp) c128vector int sexp)
(assert (< -1 arg2 (uvector-length arg1))))
(assert (mutable? arg1) (< -1 arg2 (uvector-length arg1))))

21
lib/srfi/231.sld
View file

@ -53,4 +53,23 @@
specialized-array-reshape
array-copy! array-stack! array-decurry! array-append! array-block!
)
(include "231/transforms.scm"))
(include "231/transforms.scm")
(cond-expand
((and chibi (library (srfi 160 f8)))
(import (srfi 160 f8))
(begin
(define-storage-class f8-storage-class
f8vector-ref f8vector-set! f8? make-f8vector f8vector-length 0)))
(else
(begin
(define f8-storage-class f32-storage-class))))
(cond-expand
((and chibi (library (srfi 160 f16)))
(import (srfi 160 f16))
(begin
(define-storage-class f16-storage-class
f16vector-ref f16vector-set! f16? make-f16vector f16vector-length 0)))
(else
(begin
(define f16-storage-class f32-storage-class))))
)

4
lib/srfi/231/transforms.scm
View file

@ -66,10 +66,6 @@
u32vector-length
#\null)
;; TODO: implement
(define f8-storage-class #f)
(define f16-storage-class #f)
;; Array transformations
(define (array-copy array . o)

10
lib/srfi/38.scm
View file

@ -221,13 +221,15 @@
(define F64 11)
(define C64 12)
(define C128 13)
(define F8 14)
(define F16 15)
(define (resolve-uniform-type c prec)
(or
(case prec
((1) (and (eqv? c #\u) U1))
((8) (case c ((#\u) U8) ((#\s) S8) (else #f)))
((16) (case c ((#\u) U16) ((#\s) S16) (else #f)))
((8) (case c ((#\u) U8) ((#\s) S8) ((#\f) F8) (else #f)))
((16) (case c ((#\u) U16) ((#\s) S16) ((#\f) F16) (else #f)))
((32) (case c ((#\u) U32) ((#\s) S32) ((#\f) F32) (else #f)))
((64) (case c ((#\u) U64) ((#\s) S64) ((#\f) F64) ((#\c) C64) (else #f)))
((128) (case c ((#\c) C128) (else #f)))
@ -429,6 +431,10 @@
(cond
((or (string-ci=? s "f") (string-ci=? s "false"))
#f)
((member s '("f8" "F8"))
(list->uvector F8 (read in)))
((member s '("f16" "F16"))
(list->uvector F16 (read in)))
((member s '("f32" "F32"))
(list->uvector F32 (read in)))
((member s '("f64" "F64"))

121
sexp.c
View file

@ -158,6 +158,10 @@ sexp sexp_write_uvector(sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp write
case SEXP_S64: sexp_write(ctx, tmp=sexp_make_integer(ctx, ((int64_t*)str)[i]), out); break;
case SEXP_U64: sexp_write(ctx, tmp=sexp_make_unsigned_integer(ctx, ((uint64_t*)str)[i]), out); break;
#if SEXP_USE_FLONUMS
#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
case SEXP_F8: sexp_flonum_value_set(f, sexp_quarter_to_double(((unsigned char*)str)[i])); sexp_write(ctx, f, out); break;
case SEXP_F16: sexp_flonum_value_set(f, sexp_half_to_double(((unsigned short*)str)[i])); sexp_write(ctx, f, out); break;
#endif
case SEXP_F32: sexp_flonum_value_set(f, ((float*)str)[i]); sexp_write(ctx, f, out); break;
case SEXP_F64: sexp_flonum_value_set(f, ((double*)str)[i]); sexp_write(ctx, f, out); break;
#endif
@ -520,6 +524,9 @@ static const char* sexp_initial_features[] = {
#if SEXP_USE_UNIFORM_VECTOR_LITERALS
"uvector",
#endif
#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
"mini-float",
#endif
#if SEXP_USE_COMPLEX
"complex",
#endif
@ -1184,7 +1191,7 @@ sexp sexp_make_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp elt_type, sex
return sexp_make_bytes(ctx, len, SEXP_ZERO);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, elt_type);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len);
if (etype < SEXP_U1 || etype > SEXP_C128)
if (etype < SEXP_U1 || etype >= SEXP_END_OF_UNIFORM_TYPES)
return sexp_xtype_exception(ctx, self, "unknown uniform vector type", elt_type);
if (elen < 0)
return sexp_xtype_exception(ctx, self, "negative length", len);
@ -3119,6 +3126,99 @@ static sexp sexp_fill_reader_labels(sexp ctx, sexp x, sexp shares, int state) {
}
#endif
#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
/* Pre-computed 1.5.2 mini-float table (CUDA __NV_E5M2). */
/* We prefer a larger exponent for wider range. */
/* Note 9 is the first natural number that can't be represented exactly. */
/* Technically the implementation allows any hand-picked set of values. */
static const double sexp_quarters[] = {
0.0, 1.52587890625e-05, 3.0517578125e-05, 4.57763671875e-05,
6.103515625e-05, 7.62939453125e-05, 9.1552734375e-05, 0.0001068115234375,
0.0001220703125, 0.000152587890625, 0.00018310546875, 0.000213623046875,
0.000244140625, 0.00030517578125, 0.0003662109375, 0.00042724609375,
0.00048828125, 0.0006103515625, 0.000732421875, 0.0008544921875,
0.0009765625, 0.001220703125, 0.00146484375, 0.001708984375,
0.001953125, 0.00244140625, 0.0029296875, 0.00341796875,
0.00390625, 0.0048828125, 0.005859375, 0.0068359375,
0.0078125, 0.009765625, 0.01171875, 0.013671875,
0.015625, 0.01953125, 0.0234375, 0.02734375,
0.03125, 0.0390625, 0.046875, 0.0546875,
0.0625, 0.078125, 0.09375, 0.109375,
0.125, 0.15625, 0.1875, 0.21875,
0.25, 0.3125, 0.375, 0.4375,
0.5, 0.625, 0.75, 0.875,
1.0, 1.25, 1.5, 1.75,
2.0, 2.5, 3.0, 3.5,
4.0, 5.0, 6.0, 7.0,
8.0, 10.0, 12.0, 14.0,
16.0, 20.0, 24.0, 28.0,
32.0, 40.0, 48.0, 56.0,
64.0, 80.0, 96.0, 112.0,
128.0, 160.0, 192.0, 224.0,
256.0, 320.0, 384.0, 448.0,
512.0, 640.0, 768.0, 896.0,
1024.0, 1280.0, 1536.0, 1792.0,
2048.0, 2560.0, 3072.0, 3584.0,
4096.0, 5120.0, 6144.0, 7168.0,
8192.0, 10240.0, 12288.0, 14336.0,
16384.0, 20480.0, 24576.0, 28672.0,
32768.0, 40960.0, 49152.0, 57344.0,
INFINITY, NAN, NAN, NAN
};
#define SEXP_QUARTERS_INFINITY_INDEX 124
#define SEXP_QUARTERS_NAN_INDEX 127
double sexp_quarter_to_double(unsigned char q) {
return q < 128 ? sexp_quarters[q] : -sexp_quarters[q-128];
}
unsigned char sexp_double_to_quarter(double f) {
int lo = 0, hi = SEXP_QUARTERS_INFINITY_INDEX - 1, mid;
if (isnan(f)) return SEXP_QUARTERS_NAN_INDEX;
if (f < 0) return 128 + sexp_double_to_quarter(-f);
if (isinf(f)) return SEXP_QUARTERS_INFINITY_INDEX;
while (lo <= hi) {
mid = (lo + hi) / 2;
if (sexp_quarters[mid] < f) {
lo = mid + 1;
} else if (sexp_quarters[mid] > f) {
hi = mid - 1;
} else {
return mid;
}
}
/* TODO: overflow to infinity? */
return (sexp_quarters[lo] - f) < (f - sexp_quarters[hi]) ? lo : hi;
}
static unsigned int float_as_int(const float f) {
union sexp_flonum_conv x;
x.flonum = f;
return x.bits;
}
static float int_as_float(const unsigned int n) {
union sexp_flonum_conv x;
x.bits = n;
return x.flonum;
}
double sexp_half_to_double(unsigned short x) {
unsigned int e = (x&0x7C00)>>10,
m = (x&0x03FF)<<13,
v = float_as_int((float)m)>>23;
return int_as_float((x&0x8000)<<16 | (e!=0)*((e+112)<<23|m) | ((e==0)&(m!=0))*((v-37)<<23|((m<<(150-v))&0x007FE000)));
}
unsigned short sexp_double_to_half(double x) {
unsigned int b = float_as_int(x)+0x00001000,
e = (b&0x7F800000)>>23,
m = b&0x007FFFFF;
return (b&0x80000000)>>16 | (e>112)*((((e-112)<<10)&0x7C00)|m>>13) | ((e<113)&(e>101))*((((0x007FF000+m)>>(125-e))+1)>>1) | (e>143)*0x7FFF;
}
#endif
static int sexp_peek_char(sexp ctx, sexp in) {
int c = sexp_read_char(ctx, in);
if (c != EOF) sexp_push_char(ctx, c, in);
@ -3129,8 +3229,16 @@ static int sexp_peek_char(sexp ctx, sexp in) {
static int sexp_resolve_uniform_type(int c, sexp len) {
switch (sexp_fixnump(len) ? sexp_unbox_fixnum(len) : 0) {
case 1: if (c=='u') return SEXP_U1; break;
case 8: if (c=='u') return SEXP_U8; if (c=='s') return SEXP_S8; break;
case 16: if (c=='u') return SEXP_U16; if (c=='s') return SEXP_S16; break;
case 8: if (c=='u') return SEXP_U8; if (c=='s') return SEXP_S8;
#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
if (c=='f') return SEXP_F8;
#endif
break;
case 16: if (c=='u') return SEXP_U16; if (c=='s') return SEXP_S16;
#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
if (c=='f') return SEXP_F16;
#endif
break;
case 32: if (c=='u') return SEXP_U32; if (c=='s') return SEXP_S32; if (c=='f') return SEXP_F32; break;
case 64: if (c=='u') return SEXP_U64; if (c=='s') return SEXP_S64; if (c=='f') return SEXP_F64; if (c=='c') return SEXP_C64; break;
case 128: if (c=='c') return SEXP_C128; break;
@ -3210,6 +3318,12 @@ sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sex
case SEXP_U64:
((uint64_t*)sexp_uvector_data(res))[i] = sexp_uint_value(sexp_car(ls)); break;
#if SEXP_USE_FLONUMS
#if SEXP_USE_MINI_FLOAT_UNIFORM_VECTORS
case SEXP_F8:
((unsigned char*)sexp_uvector_data(res))[i] = sexp_double_to_quarter(sexp_to_double(ctx, sexp_car(ls))); break;
case SEXP_F16:
((unsigned short*)sexp_uvector_data(res))[i] = sexp_double_to_half(sexp_to_double(ctx, sexp_car(ls))); break;
#endif
case SEXP_F32:
((float*)sexp_uvector_data(res))[i] = sexp_to_double(ctx, sexp_car(ls)); break;
case SEXP_F64:
@ -3478,6 +3592,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
} else if (c2 != SEXP_NOT_A_UNIFORM_TYPE) {
tmp = sexp_read_one(ctx, in, shares);
res = sexp_list_to_uvector(ctx, sexp_make_fixnum(c2), tmp);
if (!sexp_exceptionp(res)) sexp_immutablep(res) = 1;
} else {
tmp = sexp_list2(ctx, sexp_make_character(c1), res);
res = sexp_read_error(ctx, "invalid uniform vector syntax #%c%c", tmp, in);

12
tools/chibi-ffi
View file

@ -234,7 +234,7 @@
(or (signed-int-type? type) (unsigned-int-type? type)))
(define (float-type? type)
(memq type '(float double long-double long-long-double f32 f64)))
(memq type '(float double long-double long-long-double f8 f16 f32 f64)))
(define (string-type? type)
(or (memq type '(char* string env-string non-null-string))
@ -278,6 +278,8 @@
((s32vector) 'SEXP_S32)
((u64vector) 'SEXP_U64)
((s64vector) 'SEXP_S64)
((f8vector) 'SEXP_F8)
((f16vector) 'SEXP_F16)
((f32vector) 'SEXP_F32)
((f64vector) 'SEXP_F64)
((c64vector) 'SEXP_C64)
@ -300,6 +302,8 @@
((s32vector) "int32_t*")
((u64vector) "uint64_t*")
((s64vector) "int64_t*")
((f8vector) "unsigned char*")
((f16vector) "unsigned short*")
((f32vector) "float*")
((f64vector) "double*")
((c64vector) "float*")
@ -749,6 +753,8 @@
((s32vector) "sexp_s32vectorp")
((u64vector) "sexp_u64vectorp")
((s64vector) "sexp_s64vectorp")
((f8vector) "sexp_f8vectorp")
((f16vector) "sexp_f16vectorp")
((f32vector) "sexp_f32vectorp")
((f64vector) "sexp_f64vectorp")
((c64vector) "sexp_c64vectorp")
@ -958,7 +964,7 @@
((string env-string non-null-string bytevector u8vector)
(if *c++?* "string" "char*"))
((fileno fileno-nonblock) "int")
((u1 u8 u16 u32 u64 s8 s16 s32 s64 f32 f64)
((u1 u8 u16 u32 u64 s8 s16 s32 s64 f8 f16 f32 f64)
(let ((a
(uniform-vector-ctype
(string->symbol
@ -1385,6 +1391,8 @@
((eq? name 'string-size) 'sexp_string_size)
((memq name '(bytevector-length u8vector-length)) 'sexp_bytes_length)
((eq? name 'uvector-length) 'sexp_uvector_length)
((eq? name 'immutable?) 'sexp_immutablep)
((eq? name 'mutable?) 'sexp_mutablep)
(else name)))
(define (write-value func val)