diff options
author | Andy Wingo <wingo@pobox.com> | 2024-03-05 23:02:25 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2024-03-17 21:40:58 +0100 |
commit | 88e0933450ed9f1cc96858641e0756ffa44c53c6 (patch) | |
tree | 1b3e2257baa7e5fe5e1057b7a14925d4d205db1c /module | |
parent | 2b58dea2d24068e2a9dbe002cdceb6fec5a13a82 (diff) | |
download | guile-88e0933450ed9f1cc96858641e0756ffa44c53c6.tar.gz |
Rework make-c-struct, parse-c-struct
* module/system/foreign.scm (bytevector-complex-single-native-ref)
(bytevector-complex-single-native-set!)
(bytevector-complex-double-native-ref)
(bytevector-complex-double-native-set!): Be more static in our
definitions.
(compile-time-eval):
(switch/compile-time-keys): New helpers.
(align): Make available at compile-time.
(read-field, read-fields, write-field, write-fields): New helpers. More
efficient than the alist.
(write-c-struct, read-c-struct): Rework in terms of new helpers.
(parse-c-struct): Just use sizeof to get the size.
Diffstat (limited to 'module')
-rw-r--r-- | module/system/foreign.scm | 232 |
1 files changed, 152 insertions, 80 deletions
diff --git a/module/system/foreign.scm b/module/system/foreign.scm index 3ddfd204b..438ecd5ed 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -16,10 +16,12 @@ (define-module (system foreign) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (system base target) #:export (void float double complex-float complex-double @@ -77,6 +79,36 @@ ;;; Structures. ;;; +(define-syntax compile-time-eval + (lambda (stx) + "Evaluate the target-dependent expression EXP at compile-time if we are +not cross-compiling; otherwise leave it to be evaluated at run-time." + (syntax-case stx () + ((_ exp) + (if (equal? (target-type) %host-type) + #`(quote + #,(datum->syntax #'here + (primitive-eval (syntax->datum #'exp)))) + #'exp))))) + +;; Note that in a cross-compiled Guile, the host and the target may have +;; different values of, say, `long'. However the explicitly-sized types +;; int8, float, etc have the same value on all platforms. sizeof on +;; these types is also a target-invariant primitive. alignof is notably +;; *not* target-invariant. + +(define-syntax switch/compile-time-keys + (syntax-rules (else) + ((_ x (k expr) ... (else alt)) + (let ((t x)) + (cond + ((eq? t (compile-time-eval k)) expr) + ... + (else alt)))))) + +(define-syntax-rule (align off alignment) + (1+ (logior (1- off) (1- alignment)))) + (define bytevector-pointer-ref (case (sizeof '*) ((8) (lambda (bv offset) @@ -93,85 +125,130 @@ (bytevector-u32-native-set! bv offset (pointer-address ptr)))) (else (error "what machine is this?")))) -(define (writer-complex set size) - (lambda (bv i val) - (set bv i (real-part val)) - (set bv (+ i size) (imag-part val)))) - -(define (reader-complex ref size) - (lambda (bv i) - (make-rectangular - (ref bv i) - (ref bv (+ i size))))) - -(define *writers* - `((,float . ,bytevector-ieee-single-native-set!) - (,double . ,bytevector-ieee-double-native-set!) - (,complex-float - . ,(writer-complex bytevector-ieee-single-native-set! (sizeof float))) - (,complex-double - . ,(writer-complex bytevector-ieee-double-native-set! (sizeof double))) - (,int8 . ,bytevector-s8-set!) - (,uint8 . ,bytevector-u8-set!) - (,int16 . ,bytevector-s16-native-set!) - (,uint16 . ,bytevector-u16-native-set!) - (,int32 . ,bytevector-s32-native-set!) - (,uint32 . ,bytevector-u32-native-set!) - (,int64 . ,bytevector-s64-native-set!) - (,uint64 . ,bytevector-u64-native-set!) - (* . ,bytevector-pointer-set!))) - -(define *readers* - `((,float . ,bytevector-ieee-single-native-ref) - (,double . ,bytevector-ieee-double-native-ref) - (,complex-float - . ,(reader-complex bytevector-ieee-single-native-ref (sizeof float))) - (,complex-double - . ,(reader-complex bytevector-ieee-double-native-ref (sizeof double))) - (,int8 . ,bytevector-s8-ref) - (,uint8 . ,bytevector-u8-ref) - (,int16 . ,bytevector-s16-native-ref) - (,uint16 . ,bytevector-u16-native-ref) - (,int32 . ,bytevector-s32-native-ref) - (,uint32 . ,bytevector-u32-native-ref) - (,int64 . ,bytevector-s64-native-ref) - (,uint64 . ,bytevector-u64-native-ref) - (* . ,bytevector-pointer-ref))) - -(define (align off alignment) - (1+ (logior (1- off) (1- alignment)))) +(define-syntax-rule (define-complex-accessors (read write) (%read %write size)) + (begin + (define (read bv offset) + (make-rectangular + (%read bv offset) + (%read bv (+ offset size)))) + (define (write bv offset val) + (%write bv offset (real-part val)) + (%write bv (+ offset size) (imag-part val))))) + +(define-complex-accessors + (bytevector-complex-single-native-ref bytevector-complex-single-native-set!) + (bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! 4)) + +(define-complex-accessors + (bytevector-complex-double-native-ref bytevector-complex-double-native-set!) + (bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! 8)) + +(define-syntax-rule (read-field %bv %offset %type) + (let ((bv %bv) + (offset %offset) + (type %type)) + (define-syntax-rule (%read type reader) + (let* ((offset (align offset (compile-time-eval (alignof type)))) + (val (reader bv offset))) + (values val + (+ offset (compile-time-eval (sizeof type)))))) + (define-syntax-rule (dispatch-read type (%%type reader) (... ...)) + (switch/compile-time-keys + type + (%%type (%read %%type reader)) + (... ...) + (else + (let ((offset (align offset (alignof type)))) + (values (read-c-struct bv offset type) + (+ offset (sizeof type))))))) + (dispatch-read + type + (int8 bytevector-s8-ref) + (uint8 bytevector-u8-ref) + (int16 bytevector-s16-native-ref) + (uint16 bytevector-u16-native-ref) + (int32 bytevector-s32-native-ref) + (uint32 bytevector-u32-native-ref) + (int64 bytevector-s64-native-ref) + (uint64 bytevector-u64-native-ref) + (float bytevector-ieee-single-native-ref) + (double bytevector-ieee-double-native-ref) + (complex-float bytevector-complex-single-native-ref) + (complex-double bytevector-complex-double-native-ref) + ('* bytevector-pointer-ref)))) + +(define-syntax read-fields + (syntax-rules () + ((read-fields () bv offset k) (k offset)) + ((read-fields ((field type) . rest) bv offset k) + (call-with-values (lambda () + (read-field bv offset (compile-time-eval type))) + (lambda (field offset) + (read-fields rest bv offset k)))))) + +(define-syntax-rule (write-field %bv %offset %type %value) + (let ((bv %bv) + (offset %offset) + (type %type) + (value %value)) + (define-syntax-rule (%write type writer) + (let ((offset (align offset (compile-time-eval (alignof type))))) + (writer bv offset value) + (+ offset (compile-time-eval (sizeof type))))) + (define-syntax-rule (dispatch-write type (%%type writer) (... ...)) + (switch/compile-time-keys + type + (%%type (%write %%type writer)) + (... ...) + (else + (let ((offset (align offset (alignof type)))) + (write-c-struct bv offset type value) + (+ offset (sizeof type)))))) + (dispatch-write + type + (int8 bytevector-s8-set!) + (uint8 bytevector-u8-set!) + (int16 bytevector-s16-native-set!) + (uint16 bytevector-u16-native-set!) + (int32 bytevector-s32-native-set!) + (uint32 bytevector-u32-native-set!) + (int64 bytevector-s64-native-set!) + (uint64 bytevector-u64-native-set!) + (float bytevector-ieee-single-native-set!) + (double bytevector-ieee-double-native-set!) + (complex-float bytevector-complex-single-native-set!) + (complex-double bytevector-complex-double-native-set!) + ('* bytevector-pointer-set!)))) + +(define-syntax write-fields + (syntax-rules () + ((write-fields () bv offset k) (k offset)) + ((write-fields ((field type) . rest) bv offset k) + (let ((offset (write-field bv offset (compile-time-eval type) field))) + (write-fields rest bv offset k))))) +;; Same as write-fields, but with run-time dispatch. (define (write-c-struct bv offset types vals) (let lp ((offset offset) (types types) (vals vals)) - (cond - ((not (pair? types)) - (or (null? vals) - (error "too many values" vals))) - ((not (pair? vals)) - (error "too few values" types)) - (else - ;; alignof will error-check - (let* ((type (car types)) - (offset (align offset (alignof type)))) - (if (pair? type) - (write-c-struct bv offset (car types) (car vals)) - ((assv-ref *writers* type) bv offset (car vals))) - (lp (+ offset (sizeof type)) (cdr types) (cdr vals))))))) + (match types + (() (match vals + (() #t) + (_ (error "too many values" vals)))) + ((type . types) + (match vals + ((val . vals) + (lp (write-field bv offset type val) types vals)) + (() (error "too few values" vals))))))) +;; Same as read-fields, but with run-time dispatch. (define (read-c-struct bv offset types) - (let lp ((offset offset) (types types) (vals '())) - (cond - ((not (pair? types)) - (reverse vals)) - (else - ;; alignof will error-check - (let* ((type (car types)) - (offset (align offset (alignof type)))) - (lp (+ offset (sizeof type)) (cdr types) - (cons (if (pair? type) - (read-c-struct bv offset (car types)) - ((assv-ref *readers* type) bv offset)) - vals))))))) + (let lp ((offset offset) (types types)) + (match types + (() '()) + ((type . types) + (call-with-values (lambda () (read-field bv offset type)) + (lambda (val offset) + (cons val (lp offset types)))))))) (define (make-c-struct types vals) (let ((bv (make-bytevector (sizeof types) 0))) @@ -179,12 +256,7 @@ (bytevector->pointer bv))) (define (parse-c-struct foreign types) - (let ((size (fold (lambda (type total) - (+ (sizeof type) - (align total (alignof type)))) - 0 - types))) - (read-c-struct (pointer->bytevector foreign size) 0 types))) + (read-c-struct (pointer->bytevector foreign (sizeof types)) 0 types)) ;;; |