Commit | Line | Data |
---|---|---|
c4af9d8c AW |
1 | ;;; figl |
2 | ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com> | |
3 | ;;; | |
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. | |
8 | ;;; | |
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. | |
13 | ;;; | |
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/>. | |
17 | ||
18 | ;;; Commentary: | |
19 | ;; | |
20 | ;; Packed binary structures. | |
21 | ;; | |
22 | ;;; Code: | |
23 | ||
24 | (define-module (figl contrib packed-struct) | |
25 | #:use-module (ice-9 futures) | |
26 | #:use-module (rnrs bytevectors) | |
27 | #:export ( | |
28 | define-packed-struct | |
3c2e9972 | 29 | packed-struct-size |
c71b6533 | 30 | packed-struct-offset |
c4af9d8c AW |
31 | pack pack* unpack unpack* |
32 | ||
33 | make-packed-array | |
34 | packed-array-length | |
35 | ||
36 | pack-each pack-each/serial | |
37 | unpack-each unpack-each/serial | |
38 | repack-each repack-each/serial | |
39 | )) | |
40 | ||
41 | (define-syntax define-packed-struct | |
42 | (lambda (stx) | |
43 | (define (stx-map-fold proc lst seed) | |
44 | (let lp ((lst lst) (out '()) (seed seed)) | |
45 | (syntax-case lst () | |
46 | (() (values (reverse out) seed)) | |
47 | ((elt . lst) | |
48 | (call-with-values (lambda () (proc #'elt seed)) | |
49 | (lambda (elt seed) | |
50 | (lp #'lst (cons elt out) seed))))))) | |
51 | ||
52 | (define (compute-layout types) | |
53 | (stx-map-fold | |
54 | (lambda (type offset) | |
55 | (define (return size ref set) | |
56 | (values #`(#,offset #,ref #,set) | |
57 | (+ offset size))) | |
58 | (case (syntax->datum type) | |
59 | ((float) (return 4 | |
60 | #'bytevector-ieee-single-native-ref | |
61 | #'bytevector-ieee-single-native-set!)) | |
62 | ((double) (return 8 | |
63 | #'bytevector-ieee-double-native-ref | |
64 | #'bytevector-ieee-double-native-set!)) | |
65 | ((int8) (return 1 | |
66 | #'bytevector-s8-ref | |
67 | #'bytevector-s8-set!)) | |
68 | ((uint8) (return 1 | |
69 | #'bytevector-u8-ref | |
70 | #'bytevector-u8-set!)) | |
71 | ((int16) (return 2 | |
72 | #'bytevector-s16-native-ref | |
73 | #'bytevector-s16-native-set!)) | |
74 | ((uint16) (return 2 | |
75 | #'bytevector-u16-native-ref | |
76 | #'bytevector-u16-native-set!)) | |
77 | ((int32) (return 4 | |
78 | #'bytevector-s32-native-ref | |
79 | #'bytevector-s32-native-set!)) | |
80 | ((uint32) (return 4 | |
81 | #'bytevector-u32-native-ref | |
82 | #'bytevector-u32-native-set!)) | |
83 | ((int64) (return 8 | |
84 | #'bytevector-s64-native-ref | |
85 | #'bytevector-s64-native-set!)) | |
86 | ((uint64) (return 8 | |
87 | #'bytevector-u64-native-ref | |
88 | #'bytevector-u64-native-set!)) | |
89 | (else (error "unrecognized type" (syntax->datum type))))) | |
90 | types | |
91 | 0)) | |
92 | ||
93 | (syntax-case stx () | |
94 | ((define-packed-struct name | |
95 | (field-name field-type) | |
96 | ...) | |
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) | |
102 | (case method | |
103 | ((size) byte-size) | |
c71b6533 AW |
104 | ((offset) |
105 | (case field | |
106 | ((field-name) field-offset) | |
107 | ... | |
108 | (else (error "unknown field" field)))) | |
c4af9d8c AW |
109 | ((unpacker) |
110 | (lambda (bv offset k) | |
111 | (k (field-ref bv (+ offset field-offset)) | |
112 | ...))) | |
113 | ((packer) | |
114 | (lambda (bv offset field-name ...) | |
115 | (field-set bv (+ offset field-offset) field-name) | |
116 | ...)) | |
117 | ((getter) | |
118 | (case field | |
119 | ((field-name) | |
120 | (lambda (bv offset) | |
121 | (field-ref bv (+ offset field-offset)))) | |
122 | ... | |
123 | (else (error "unknown field" field)))) | |
124 | ((setter) | |
125 | (case field | |
126 | ((field-name) | |
127 | (lambda (bv offset val) | |
128 | (field-set bv (+ offset field-offset) val))) | |
129 | ... | |
130 | (else (error "unknown field" field))))))))))))) | |
131 | ||
132 | (define-syntax-rule (packed-struct-size type) | |
133 | (type 'size #f)) | |
134 | ||
c71b6533 AW |
135 | (define-syntax-rule (packed-struct-offset type field) |
136 | (type 'offset 'field)) | |
137 | ||
c4af9d8c AW |
138 | (define-syntax-rule (packed-struct-getter type field) |
139 | (type 'getter 'field)) | |
140 | ||
141 | (define-syntax-rule (packed-struct-setter type field) | |
142 | (type 'setter 'field)) | |
143 | ||
144 | (define-syntax-rule (packed-struct-unpacker type) | |
145 | (type 'unpacker #f)) | |
146 | ||
147 | (define-syntax-rule (packed-struct-packer type) | |
148 | (type 'packer #f)) | |
149 | ||
150 | (define-syntax-rule (unpack* bv offset type k) | |
151 | ((packed-struct-unpacker type) bv offset k)) | |
152 | ||
153 | (define-syntax-rule (unpack bv n type k) | |
154 | (unpack* bv (* n (packed-struct-size type)) type k)) | |
155 | ||
156 | (define-syntax-rule (pack* bv offset type v ...) | |
157 | ((packed-struct-packer type) bv offset v ...)) | |
158 | ||
159 | (define-syntax-rule (pack bv n type v ...) | |
160 | (pack* bv (* n (packed-struct-size type)) type v ...)) | |
161 | ||
162 | (define-syntax-rule (make-packed-array type len) | |
163 | (make-bytevector (* (packed-struct-size type) len) 0)) | |
164 | ||
165 | (define-syntax-rule (packed-array-length bv type) | |
166 | (/ (bytevector-length bv) (packed-struct-size type))) | |
167 | ||
168 | (define* (parallel-iota n proc #:optional (nprocs (current-processor-count))) | |
169 | (let lp ((start 0) (end n) (nprocs nprocs)) | |
170 | (cond | |
171 | ((= start end)) | |
172 | ((= nprocs 1) | |
173 | (let lp ((n start)) | |
174 | (when (< n end) | |
175 | (proc n) | |
176 | (lp (1+ n))))) | |
177 | (else | |
178 | (let* ((pivot (+ start (ceiling/ (- end start) nprocs))) | |
179 | (left (future (lp start pivot 1)))) | |
180 | (lp pivot end (1- nprocs)) | |
181 | (touch left)))))) | |
182 | ||
183 | (define-syntax-rule (pack-each* bv type proc nprocs) | |
184 | (parallel-iota (packed-array-length bv type) | |
185 | (lambda (n) | |
186 | (call-with-values (lambda () (proc n)) | |
187 | (lambda args | |
188 | (apply (packed-struct-packer type) | |
189 | bv | |
190 | (* n (packed-struct-size type)) | |
191 | args)))) | |
192 | nprocs)) | |
193 | ||
194 | (define-syntax-rule (pack-each bv type proc) | |
195 | (pack-each* bv type proc (current-processor-count))) | |
196 | ||
197 | (define-syntax-rule (pack-each/serial bv type proc) | |
198 | (pack-each* bv type proc 1)) | |
199 | ||
200 | (define-syntax-rule (unpack-each* bv type proc nprocs) | |
201 | (parallel-iota (packed-array-length bv type) | |
202 | (lambda (n) | |
203 | ((packed-struct-unpacker type) | |
204 | bv | |
205 | (* n (packed-struct-size type)) | |
206 | (lambda args | |
207 | (apply proc n args)))) | |
208 | nprocs)) | |
209 | ||
210 | (define-syntax-rule (unpack-each bv type proc) | |
211 | (unpack-each* bv type proc (current-processor-count))) | |
212 | ||
213 | (define-syntax-rule (unpack-each/serial bv type proc) | |
214 | (unpack-each* bv type proc 1)) | |
215 | ||
216 | (define-syntax-rule (repack-each* bv type proc nprocs) | |
217 | (pack-each* bv type | |
218 | (lambda (n) | |
219 | ((packed-struct-unpacker type) | |
220 | bv | |
221 | (* n (packed-struct-size type)) | |
222 | (lambda args | |
223 | (apply proc n args)))) | |
224 | nprocs)) | |
225 | ||
226 | (define-syntax-rule (repack-each bv type proc) | |
227 | (repack-each* bv type proc (current-processor-count))) | |
228 | ||
229 | (define-syntax-rule (repack-each/serial bv type proc) | |
230 | (repack-each* bv type proc 1)) |