figl/contrib/packed-struct.scm

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