2 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
4 ;;; Figl is free software: you can redistribute it and/or modify it
5 ;;; under the terms of the GNU Lesser General Public License as
6 ;;; published by the Free Software Foundation, either version 3 of the
7 ;;; License, or (at your option) any later version.
9 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
10 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
11 ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
12 ;;; Public License for more details.
14 ;;; You should have received a copy of the GNU Lesser General Public
15 ;;; License along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
20 ;; Packed binary structures.
24 (define-module (figl contrib packed-struct)
25 #:use-module (ice-9 futures)
26 #:use-module (rnrs bytevectors)
30 pack pack* unpack unpack*
35 pack-each pack-each/serial
36 unpack-each unpack-each/serial
37 repack-each repack-each/serial
40 (define-syntax define-packed-struct
42 (define (stx-map-fold proc lst seed)
43 (let lp ((lst lst) (out '()) (seed seed))
45 (() (values (reverse out) seed))
47 (call-with-values (lambda () (proc #'elt seed))
49 (lp #'lst (cons elt out) seed)))))))
51 (define (compute-layout types)
54 (define (return size ref set)
55 (values #`(#,offset #,ref #,set)
57 (case (syntax->datum type)
59 #'bytevector-ieee-single-native-ref
60 #'bytevector-ieee-single-native-set!))
62 #'bytevector-ieee-double-native-ref
63 #'bytevector-ieee-double-native-set!))
66 #'bytevector-s8-set!))
69 #'bytevector-u8-set!))
71 #'bytevector-s16-native-ref
72 #'bytevector-s16-native-set!))
74 #'bytevector-u16-native-ref
75 #'bytevector-u16-native-set!))
77 #'bytevector-s32-native-ref
78 #'bytevector-s32-native-set!))
80 #'bytevector-u32-native-ref
81 #'bytevector-u32-native-set!))
83 #'bytevector-s64-native-ref
84 #'bytevector-s64-native-set!))
86 #'bytevector-u64-native-ref
87 #'bytevector-u64-native-set!))
88 (else (error "unrecognized type" (syntax->datum type)))))
93 ((define-packed-struct name
94 (field-name field-type)
96 (call-with-values (lambda () (compute-layout #'(field-type ...)))
97 (lambda (accessors byte-size)
98 (with-syntax ((((field-offset field-ref field-set) ...) accessors)
99 (byte-size byte-size))
100 #`(define-inlinable (name method field)
104 (lambda (bv offset k)
105 (k (field-ref bv (+ offset field-offset))
108 (lambda (bv offset field-name ...)
109 (field-set bv (+ offset field-offset) field-name)
115 (field-ref bv (+ offset field-offset))))
117 (else (error "unknown field" field))))
121 (lambda (bv offset val)
122 (field-set bv (+ offset field-offset) val)))
124 (else (error "unknown field" field)))))))))))))
126 (define-syntax-rule (packed-struct-size type)
129 (define-syntax-rule (packed-struct-getter type field)
130 (type 'getter 'field))
132 (define-syntax-rule (packed-struct-setter type field)
133 (type 'setter 'field))
135 (define-syntax-rule (packed-struct-unpacker type)
138 (define-syntax-rule (packed-struct-packer type)
141 (define-syntax-rule (unpack* bv offset type k)
142 ((packed-struct-unpacker type) bv offset k))
144 (define-syntax-rule (unpack bv n type k)
145 (unpack* bv (* n (packed-struct-size type)) type k))
147 (define-syntax-rule (pack* bv offset type v ...)
148 ((packed-struct-packer type) bv offset v ...))
150 (define-syntax-rule (pack bv n type v ...)
151 (pack* bv (* n (packed-struct-size type)) type v ...))
153 (define-syntax-rule (make-packed-array type len)
154 (make-bytevector (* (packed-struct-size type) len) 0))
156 (define-syntax-rule (packed-array-length bv type)
157 (/ (bytevector-length bv) (packed-struct-size type)))
159 (define* (parallel-iota n proc #:optional (nprocs (current-processor-count)))
160 (let lp ((start 0) (end n) (nprocs nprocs))
169 (let* ((pivot (+ start (ceiling/ (- end start) nprocs)))
170 (left (future (lp start pivot 1))))
171 (lp pivot end (1- nprocs))
174 (define-syntax-rule (pack-each* bv type proc nprocs)
175 (parallel-iota (packed-array-length bv type)
177 (call-with-values (lambda () (proc n))
179 (apply (packed-struct-packer type)
181 (* n (packed-struct-size type))
185 (define-syntax-rule (pack-each bv type proc)
186 (pack-each* bv type proc (current-processor-count)))
188 (define-syntax-rule (pack-each/serial bv type proc)
189 (pack-each* bv type proc 1))
191 (define-syntax-rule (unpack-each* bv type proc nprocs)
192 (parallel-iota (packed-array-length bv type)
194 ((packed-struct-unpacker type)
196 (* n (packed-struct-size type))
198 (apply proc n args))))
201 (define-syntax-rule (unpack-each bv type proc)
202 (unpack-each* bv type proc (current-processor-count)))
204 (define-syntax-rule (unpack-each/serial bv type proc)
205 (unpack-each* bv type proc 1))
207 (define-syntax-rule (repack-each* bv type proc nprocs)
210 ((packed-struct-unpacker type)
212 (* n (packed-struct-size type))
214 (apply proc n args))))
217 (define-syntax-rule (repack-each bv type proc)
218 (repack-each* bv type proc (current-processor-count)))
220 (define-syntax-rule (repack-each/serial bv type proc)
221 (repack-each* bv type proc 1))