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)
31 pack pack* unpack unpack*
36 pack-each pack-each/serial
37 unpack-each unpack-each/serial
38 repack-each repack-each/serial
41 (define-syntax define-packed-struct
43 (define (stx-map-fold proc lst seed)
44 (let lp ((lst lst) (out '()) (seed seed))
46 (() (values (reverse out) seed))
48 (call-with-values (lambda () (proc #'elt seed))
50 (lp #'lst (cons elt out) seed)))))))
52 (define (compute-layout types)
55 (define (return size ref set)
56 (values #`(#,offset #,ref #,set)
58 (case (syntax->datum type)
60 #'bytevector-ieee-single-native-ref
61 #'bytevector-ieee-single-native-set!))
63 #'bytevector-ieee-double-native-ref
64 #'bytevector-ieee-double-native-set!))
67 #'bytevector-s8-set!))
70 #'bytevector-u8-set!))
72 #'bytevector-s16-native-ref
73 #'bytevector-s16-native-set!))
75 #'bytevector-u16-native-ref
76 #'bytevector-u16-native-set!))
78 #'bytevector-s32-native-ref
79 #'bytevector-s32-native-set!))
81 #'bytevector-u32-native-ref
82 #'bytevector-u32-native-set!))
84 #'bytevector-s64-native-ref
85 #'bytevector-s64-native-set!))
87 #'bytevector-u64-native-ref
88 #'bytevector-u64-native-set!))
89 (else (error "unrecognized type" (syntax->datum type)))))
94 ((define-packed-struct name
95 (field-name field-type)
97 (call-with-values (lambda () (compute-layout #'(field-type ...)))
98 (lambda (accessors byte-size)
99 (with-syntax ((((field-offset field-ref field-set) ...) accessors)
100 (byte-size byte-size))
101 #`(define-inlinable (name method field)
106 ((field-name) field-offset)
108 (else (error "unknown field" field))))
110 (lambda (bv offset k)
111 (k (field-ref bv (+ offset field-offset))
114 (lambda (bv offset field-name ...)
115 (field-set bv (+ offset field-offset) field-name)
121 (field-ref bv (+ offset field-offset))))
123 (else (error "unknown field" field))))
127 (lambda (bv offset val)
128 (field-set bv (+ offset field-offset) val)))
130 (else (error "unknown field" field)))))))))))))
132 (define-syntax-rule (packed-struct-size type)
135 (define-syntax-rule (packed-struct-offset type field)
136 (type 'offset 'field))
138 (define-syntax-rule (packed-struct-getter type field)
139 (type 'getter 'field))
141 (define-syntax-rule (packed-struct-setter type field)
142 (type 'setter 'field))
144 (define-syntax-rule (packed-struct-unpacker type)
147 (define-syntax-rule (packed-struct-packer type)
150 (define-syntax-rule (unpack* bv offset type k)
151 ((packed-struct-unpacker type) bv offset k))
153 (define-syntax-rule (unpack bv n type k)
154 (unpack* bv (* n (packed-struct-size type)) type k))
156 (define-syntax-rule (pack* bv offset type v ...)
157 ((packed-struct-packer type) bv offset v ...))
159 (define-syntax-rule (pack bv n type v ...)
160 (pack* bv (* n (packed-struct-size type)) type v ...))
162 (define-syntax-rule (make-packed-array type len)
163 (make-bytevector (* (packed-struct-size type) len) 0))
165 (define-syntax-rule (packed-array-length bv type)
166 (/ (bytevector-length bv) (packed-struct-size type)))
168 (define* (parallel-iota n proc #:optional (nprocs (current-processor-count)))
169 (let lp ((start 0) (end n) (nprocs nprocs))
178 (let* ((pivot (+ start (ceiling/ (- end start) nprocs)))
179 (left (future (lp start pivot 1))))
180 (lp pivot end (1- nprocs))
183 (define-syntax-rule (pack-each* bv type proc nprocs)
184 (parallel-iota (packed-array-length bv type)
186 (call-with-values (lambda () (proc n))
188 (apply (packed-struct-packer type)
190 (* n (packed-struct-size type))
194 (define-syntax-rule (pack-each bv type proc)
195 (pack-each* bv type proc (current-processor-count)))
197 (define-syntax-rule (pack-each/serial bv type proc)
198 (pack-each* bv type proc 1))
200 (define-syntax-rule (unpack-each* bv type proc nprocs)
201 (parallel-iota (packed-array-length bv type)
203 ((packed-struct-unpacker type)
205 (* n (packed-struct-size type))
207 (apply proc n args))))
210 (define-syntax-rule (unpack-each bv type proc)
211 (unpack-each* bv type proc (current-processor-count)))
213 (define-syntax-rule (unpack-each/serial bv type proc)
214 (unpack-each* bv type proc 1))
216 (define-syntax-rule (repack-each* bv type proc nprocs)
219 ((packed-struct-unpacker type)
221 (* n (packed-struct-size type))
223 (apply proc n args))))
226 (define-syntax-rule (repack-each bv type proc)
227 (repack-each* bv type proc (current-processor-count)))
229 (define-syntax-rule (repack-each/serial bv type proc)
230 (repack-each* bv type proc 1))