export packed-struct-size

[clinton/guile-figl.git] / figl / contrib / packed-struct.scm

;;; figl
;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
;;; 
;;; Figl is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;; 
;;; Figl is distributed in the hope that it will be useful, but WITHOUT
;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
;;; Public License for more details.
;;; 
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Packed binary structures.
;;
;;; Code:

(define-module (figl contrib packed-struct)
  #:use-module (ice-9 futures)
  #:use-module (rnrs bytevectors)
  #:export (
            define-packed-struct
            packed-struct-size
            pack pack* unpack unpack*

            make-packed-array
            packed-array-length

            pack-each pack-each/serial
            unpack-each unpack-each/serial
            repack-each repack-each/serial
            ))

(define-syntax define-packed-struct
  (lambda (stx)
    (define (stx-map-fold proc lst seed)
      (let lp ((lst lst) (out '()) (seed seed))
        (syntax-case lst ()
          (() (values (reverse out) seed))
          ((elt . lst)
           (call-with-values (lambda () (proc #'elt seed))
             (lambda (elt seed)
               (lp #'lst (cons elt out) seed)))))))

    (define (compute-layout types)
      (stx-map-fold
       (lambda (type offset)
         (define (return size ref set)
           (values #`(#,offset #,ref #,set)
                   (+ offset size)))
         (case (syntax->datum type)
           ((float)  (return 4
                             #'bytevector-ieee-single-native-ref
                             #'bytevector-ieee-single-native-set!))
           ((double) (return 8
                             #'bytevector-ieee-double-native-ref
                             #'bytevector-ieee-double-native-set!))
           ((int8)   (return 1
                             #'bytevector-s8-ref
                             #'bytevector-s8-set!))
           ((uint8)  (return 1
                             #'bytevector-u8-ref
                             #'bytevector-u8-set!))
           ((int16)  (return 2
                             #'bytevector-s16-native-ref
                             #'bytevector-s16-native-set!))
           ((uint16) (return 2
                             #'bytevector-u16-native-ref
                             #'bytevector-u16-native-set!))
           ((int32)  (return 4
                             #'bytevector-s32-native-ref
                             #'bytevector-s32-native-set!))
           ((uint32) (return 4
                             #'bytevector-u32-native-ref
                             #'bytevector-u32-native-set!))
           ((int64)  (return 8
                             #'bytevector-s64-native-ref
                             #'bytevector-s64-native-set!))
           ((uint64) (return 8
                             #'bytevector-u64-native-ref
                             #'bytevector-u64-native-set!))
           (else (error "unrecognized type" (syntax->datum type)))))
       types
       0))

    (syntax-case stx ()
      ((define-packed-struct name
         (field-name field-type)
         ...)
       (call-with-values (lambda () (compute-layout #'(field-type ...)))
         (lambda (accessors byte-size)
           (with-syntax ((((field-offset field-ref field-set) ...) accessors)
                         (byte-size byte-size))
             #`(define-inlinable (name method field)
                 (case method
                   ((size) byte-size)
                   ((unpacker)
                    (lambda (bv offset k)
                      (k (field-ref bv (+ offset field-offset))
                         ...)))
                   ((packer)
                    (lambda (bv offset field-name ...)
                      (field-set bv (+ offset field-offset) field-name)
                      ...))
                   ((getter)
                    (case field
                      ((field-name)
                       (lambda (bv offset)
                         (field-ref bv (+ offset field-offset))))
                      ...
                      (else (error "unknown field" field))))
                   ((setter)
                    (case field
                      ((field-name)
                       (lambda (bv offset val)
                         (field-set bv (+ offset field-offset) val)))
                      ...
                      (else (error "unknown field" field)))))))))))))

(define-syntax-rule (packed-struct-size type)
  (type 'size #f))

(define-syntax-rule (packed-struct-getter type field)
  (type 'getter 'field))

(define-syntax-rule (packed-struct-setter type field)
  (type 'setter 'field))

(define-syntax-rule (packed-struct-unpacker type)
  (type 'unpacker #f))

(define-syntax-rule (packed-struct-packer type)
  (type 'packer #f))

(define-syntax-rule (unpack* bv offset type k)
  ((packed-struct-unpacker type) bv offset k))

(define-syntax-rule (unpack bv n type k)
  (unpack* bv (* n (packed-struct-size type)) type k))

(define-syntax-rule (pack* bv offset type v ...)
  ((packed-struct-packer type) bv offset v ...))

(define-syntax-rule (pack bv n type v ...)
  (pack* bv (* n (packed-struct-size type)) type v ...))

(define-syntax-rule (make-packed-array type len)
  (make-bytevector (* (packed-struct-size type) len) 0))

(define-syntax-rule (packed-array-length bv type)
  (/ (bytevector-length bv) (packed-struct-size type)))

(define* (parallel-iota n proc #:optional (nprocs (current-processor-count)))
  (let lp ((start 0) (end n) (nprocs nprocs))
    (cond
     ((= start end))
     ((= nprocs 1)
      (let lp ((n start))
        (when (< n end)
          (proc n)
          (lp (1+ n)))))
     (else
      (let* ((pivot (+ start (ceiling/ (- end start) nprocs)))
             (left (future (lp start pivot 1))))
        (lp pivot end (1- nprocs))
        (touch left))))))

(define-syntax-rule (pack-each* bv type proc nprocs)
  (parallel-iota (packed-array-length bv type)
                 (lambda (n)
                   (call-with-values (lambda () (proc n))
                     (lambda args
                       (apply (packed-struct-packer type)
                              bv
                              (* n (packed-struct-size type))
                              args))))
                 nprocs))

(define-syntax-rule (pack-each bv type proc)
  (pack-each* bv type proc (current-processor-count)))

(define-syntax-rule (pack-each/serial bv type proc)
  (pack-each* bv type proc 1))

(define-syntax-rule (unpack-each* bv type proc nprocs)
  (parallel-iota (packed-array-length bv type)
                 (lambda (n)
                   ((packed-struct-unpacker type)
                    bv
                    (* n (packed-struct-size type))
                    (lambda args
                      (apply proc n args))))
                 nprocs))

(define-syntax-rule (unpack-each bv type proc)
  (unpack-each* bv type proc (current-processor-count)))

(define-syntax-rule (unpack-each/serial bv type proc)
  (unpack-each* bv type proc 1))

(define-syntax-rule (repack-each* bv type proc nprocs)
  (pack-each* bv type
              (lambda (n)
                ((packed-struct-unpacker type)
                 bv
                 (* n (packed-struct-size type))
                 (lambda args
                   (apply proc n args))))
              nprocs))

(define-syntax-rule (repack-each bv type proc)
  (repack-each* bv type proc (current-processor-count)))

(define-syntax-rule (repack-each/serial bv type proc)
  (repack-each* bv type proc 1))