mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Rework make-c-struct, parse-c-struct

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2024-03-05 23:02:25 +01:00
parent 2b58dea2d2
commit 88e0933450
1 changed files with 148 additions and 76 deletions
Download patch file Download diff file Expand all files Collapse all files

224
module/system/foreign.scm
View file

@ -16,10 +16,12 @@
(define-module (system foreign) (define-module (system foreign)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (system base target)
#:export (void #:export (void
float double float double
complex-float complex-double complex-float complex-double
@ -77,6 +79,36 @@
;;; Structures. ;;; 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 (define bytevector-pointer-ref
(case (sizeof '*) (case (sizeof '*)
((8) (lambda (bv offset) ((8) (lambda (bv offset)
@ -93,85 +125,130 @@
(bytevector-u32-native-set! bv offset (pointer-address ptr)))) (bytevector-u32-native-set! bv offset (pointer-address ptr))))
(else (error "what machine is this?")))) (else (error "what machine is this?"))))
(define (writer-complex set size) (define-syntax-rule (define-complex-accessors (read write) (%read %write size))
(lambda (bv i val) (begin
(set bv i (real-part val)) (define (read bv offset)
(set bv (+ i size) (imag-part val)))) (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 (reader-complex ref size) (define-complex-accessors
(lambda (bv i) (bytevector-complex-single-native-ref bytevector-complex-single-native-set!)
(make-rectangular (bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! 4))
(ref bv i)
(ref bv (+ i size)))))
(define *writers* (define-complex-accessors
`((,float . ,bytevector-ieee-single-native-set!) (bytevector-complex-double-native-ref bytevector-complex-double-native-set!)
(,double . ,bytevector-ieee-double-native-set!) (bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! 8))
(,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* (define-syntax-rule (read-field %bv %offset %type)
`((,float . ,bytevector-ieee-single-native-ref) (let ((bv %bv)
(,double . ,bytevector-ieee-double-native-ref) (offset %offset)
(,complex-float (type %type))
. ,(reader-complex bytevector-ieee-single-native-ref (sizeof float))) (define-syntax-rule (%read type reader)
(,complex-double (let* ((offset (align offset (compile-time-eval (alignof type))))
. ,(reader-complex bytevector-ieee-double-native-ref (sizeof double))) (val (reader bv offset)))
(,int8 . ,bytevector-s8-ref) (values val
(,uint8 . ,bytevector-u8-ref) (+ offset (compile-time-eval (sizeof type))))))
(,int16 . ,bytevector-s16-native-ref) (define-syntax-rule (dispatch-read type (%%type reader) (... ...))
(,uint16 . ,bytevector-u16-native-ref) (switch/compile-time-keys
(,int32 . ,bytevector-s32-native-ref) type
(,uint32 . ,bytevector-u32-native-ref) (%%type (%read %%type reader))
(,int64 . ,bytevector-s64-native-ref) (... ...)
(,uint64 . ,bytevector-u64-native-ref) (else
(* . ,bytevector-pointer-ref))) (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 (align off alignment) (define-syntax read-fields
(1+ (logior (1- off) (1- alignment)))) (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) (define (write-c-struct bv offset types vals)
(let lp ((offset offset) (types types) (vals vals)) (let lp ((offset offset) (types types) (vals vals))
(cond (match types
((not (pair? types)) (() (match vals
(or (null? vals) (() #t)
(error "too many values" vals))) (_ (error "too many values" vals))))
((not (pair? vals)) ((type . types)
(error "too few values" types)) (match vals
(else ((val . vals)
;; alignof will error-check (lp (write-field bv offset type val) types vals))
(let* ((type (car types)) (() (error "too few values" vals)))))))
(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)))))))
;; Same as read-fields, but with run-time dispatch.
(define (read-c-struct bv offset types) (define (read-c-struct bv offset types)
(let lp ((offset offset) (types types) (vals '())) (let lp ((offset offset) (types types))
(cond (match types
((not (pair? types)) (() '())
(reverse vals)) ((type . types)
(else (call-with-values (lambda () (read-field bv offset type))
;; alignof will error-check (lambda (val offset)
(let* ((type (car types)) (cons val (lp offset 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)))))))
(define (make-c-struct types vals) (define (make-c-struct types vals)
(let ((bv (make-bytevector (sizeof types) 0))) (let ((bv (make-bytevector (sizeof types) 0)))
@ -179,12 +256,7 @@
(bytevector->pointer bv))) (bytevector->pointer bv)))
(define (parse-c-struct foreign types) (define (parse-c-struct foreign types)
(let ((size (fold (lambda (type total) (read-c-struct (pointer->bytevector foreign (sizeof types)) 0 types))
(+ (sizeof type)
(align total (alignof type))))
0
types)))
(read-c-struct (pointer->bytevector foreign size) 0 types)))
;;; ;;;