;;; -*- Mode: Scheme; scheme48-package: fasdumping -*-

;;;; Fasdumper

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define (make-fasdump-port type data encoder-selector id)
  (make-buffered-output-port fasdump-port-handler
                             (make-fasdumper type data
                                             encoder-selector
                                             (if (null? id)
                                                 #f
                                                 (car id)))
                             (make-byte-vector default-buffer-size 0)
                             0
                             default-buffer-size))

(define-record-type* fasdumper
  (make-fasdumper type
                  data
                  (encoder-selector)
                  id)
  ((objects (make-object-table))))

(define (set-fasdump-port-encoder-selector! fasdump-port selector)
  (set-fasdumper-encoder-selector!
   (guarantee-fasdump-port fasdump-port)
   selector))

(define (with-fasdump-port-encoder-selector fasdump-port new-selector
          body)
  (let* ((fasdumper (guarantee-fasdump-port fasdump-port))
         (old-selector (fasdumper-encoder-selector fasdumper)))
    (dynamic-wind
      (lambda ()
        (set-fasdumper-encoder-selector! fasdumper new-selector))
      body
      (lambda ()
        (set-fasdumper-encoder-selector! fasdumper old-selector)))))

(define-record-type* fasdumper-type
  (make-fasdumper-type id
                       immediate-dumper
                       reference-dumper
                       byte-vector-dumper
                       object-dumper)
  ())

(define-syntax define-fasdump-methods
  (syntax-rules ()
    ((DEFINE-FASDUMP-METHODS
       ((proc arg ...) field)
       ...)
     (BEGIN (DEFINE (proc FASDUMPER arg ...)
              ((field (FASDUMPER-TYPE FASDUMPER))
               (FASDUMPER-DATA FASDUMPER)
               arg
               ...))
            ...))))

(define-fasdump-methods
  ((fasdump-immediate-item type) fasdumper-type-immediate-dumper)
  ((fasdump-reference-item descriptor) fasdumper-type-reference-dumper)
  ((fasdump-byte-vector-item bytev) fasdumper-type-byte-vector-dumper)
  ((fasdump-object-item port type obj)
   fasdumper-type-object-dumper))

(define (fasdump-port? obj)
  (and (port? obj)
       (fasdumper? (port-data obj))))

(define (guarantee-fasdump-port obj)
  (define (lose)
    (error "invalid fasdump port" obj))
  (if (port? obj)
      (let ((data (port-data obj)))
        (if (fasdumper? data)
            data
            (lose)))
      (lose)))

;;;; Fasdumping Entry Points

(define (fasdump obj port . encoder-selector-option)
  (let ((fasdumper (guarantee-fasdump-port port)))
    (force-output port)
    (let ((select-encoder
           (if (null? encoder-selector-option)
               (fasdumper-encoder-selector fasdumper)
               (car encoder-selector-option))))
      (receive (immediate? type encoder)
               (select-encoder obj)
        (if (not type)
            (signal-fasl-undumpable port obj select-encoder)
            (cond (immediate?
                   (fasdump-immediate-item fasdumper type)
                   (encoder obj port))
                  ((table-entry (fasdumper-objects fasdumper) obj)
                   => (lambda (descriptor)
                        (fasdump-reference-item fasdumper descriptor)))
                  (else
                   (fasdump-object-item fasdumper port type obj)
                   (encoder obj port))))))))

(define (encoder->fasdumper encoder)
  (lambda (obj port type)
    (let ((fasdumper (guarantee-fasdump-port port)))
      (force-output port)
      (cond ((table-entry (fasdumper-objects fasdumper) obj)
             => (lambda (descriptor)
                  (fasdump-reference-item fasdumper descriptor)))
            (else
             (fasdump-object-item fasdumper port type obj)
             (encoder obj port))))))

(define (immediate-encoder->fasdumper encoder)
  (lambda (obj port type)
    (let ((fasdumper (guarantee-fasdump-port port)))
      (force-output port)
      (fasdump-immediate-item fasdumper type)
      (encoder obj port))))

;;; Integers are encoded as sequences of little-endian 7-bit chunks;
;;; each octet's eighth bit is clear, until the last one, whose set
;;; eighth bit signals the termination of the sequence.

(define (write-fasl-integer integer port)
  (do ((i integer (arithmetic-shift i -7)))
      ((< i #x80)
       (write-octet (adjoin-bit-field 7 i 1) port))
    (write-octet (bitwise-and i #x7F) port)))

(define (write-fasl-string string port)
  (write-fasl-integer (string-length string) port)
  (write-string string port))

;;;; Fasdump Port Handler

(define fasdump-port-handler)

(define (initialize-fasdump-ports!)
  (set! fasdump-port-handler
        (make-buffered-output-port-handler disclose-fasdumper
                                           close-fasdumper
                                           empty-fasdumper-buffer
                                           fasdumper-char-ready?)))

(define (disclose-fasdumper fasdumper)
  (let ((type-id (fasdumper-type-id (fasdumper-type fasdumper)))
        (id (fasdumper-id fasdumper)))
    (if id
        (list type-id id)
        (list type-id))))

(define (close-fasdumper fasdumper)
  fasdumper                             ; ignore
  (values))

(define (fasdumper-char-ready? port)
  port                                  ; ignore
  (values #t #t))

(define (empty-fasdumper-buffer port necessary?)
  necessary?                            ; ignore
  (fasdump-byte-vector-item
   (port-data port)
   (let* ((index (provisional-port-index port))
          (bytev (make-byte-vector index 0)))
     (attempt-copy-bytes! (port-buffer port) 0
                          bytev              0
                          index)
     (provisional-set-port-index! port 0)
     (note-buffer-reuse! port)
     bytev))
  (maybe-commit))

;;;; Block Fasdumping

(define-record-type* fasdump-block
  (make-fasdump-block)
  ((contents (make-queue))
   (types (make-queue))
   (shared-count 0)))

(define block-fasdumper-type)

(define (initialize-block-fasdumper-type!)
  (set! block-fasdumper-type
        (make-fasdumper-type 'BLOCK-FASDUMP-PORT
                             block-fasdump-immediate
                             block-fasdump-reference
                             block-fasdump-byte-vector
                             block-fasdump-object)))

(define (make-block-fasdump-port encoder-selector . id)
  (make-fasdump-port block-fasdumper-type
                     (make-fasdump-block)
                     encoder-selector
                     id))

(define-enumeration fasdump-item
  (immediate
   reference
   byte-vector
   object))

(define (block-fasdump-immediate block type)
  (enqueue! (fasdump-block-contents block)
            (cons (enum fasdump-item IMMEDIATE)
                  (encode-fasdump-type type block))))

(define (block-fasdump-reference block descriptor)
  (cond ((not (fasdump-descriptor-shared? descriptor))
         (set-fasdump-descriptor-shared?! descriptor #t)
         (set-fasdump-block-shared-count!
          block
          (+ 1 (fasdump-block-shared-count block)))))
  (enqueue! (fasdump-block-contents block)
            (cons (enum fasdump-item REFERENCE)
                  descriptor)))

(define (block-fasdump-byte-vector block bytev)
  (enqueue! (fasdump-block-contents block)
            (cons (enum fasdump-item BYTE-VECTOR)
                  bytev)))

(define (block-fasdump-object block port type obj)
  (let ((descriptor
         (make-fasdump-descriptor (encode-fasdump-type type block)
                                  obj)))
    (set-table-entry! (fasdumper-objects (port-data port))
                      obj
                      descriptor)
    (enqueue! (fasdump-block-contents block)
              (cons (enum fasdump-item OBJECT)
                    descriptor))))

(define (encode-fasdump-type type block)
  (maybe-enqueue! (fasdump-block-types block) type))

(define-record-type* fasdump-descriptor
  (make-fasdump-descriptor type object)
  ((shared? #f)
   (index #f)))

;;;;; Writing Block Fasdumps

(define (write-block-fasdump fasdump-port output-port)
  (%write-block-fasdump fasdump-port output-port
    walk-queue
    (lambda (fasdumper block)
      fasdumper block                   ; ignored
      (values))))

(define (write-block-fasdump! fasdump-port output-port)
  (%write-block-fasdump fasdump-port output-port
    walk-queue!
    (let ((new-table (make-object-table)))
      (lambda (fasdumper block)
        (set-fasdumper-objects! fasdumper new-table)
        (set-fasdump-block-shared-count! block 0)))))

(define (%write-block-fasdump fasdump-port output-port
          walk-output-queue
          finish)
  (let* ((fasdumper (guarantee-fasdump-port fasdump-port))
         (block (fasdumper-data fasdumper)))
    (force-output fasdump-port)
    (write-block-fasl-identification block output-port)
    (walk-output-queue
     (fasdump-block-types block)
     (lambda (type)
       (let ((string (symbol->string type)))
         (write-fasl-integer (string-length string) output-port)
         (write-string string output-port))))
    (walk-output-queue
     (fasdump-block-contents block)
     (let ((index-cell (make-cell 0)))
       (lambda (item)
         (write-block-fasl-item item output-port index-cell))))
    (finish fasdumper block)))

(define (write-block-fasl-identification block output-port)
  (write-string fasl-identification output-port)
  (write-char #\newline output-port)
  (write-fasl-integer fasl-newest-version output-port)
  (write-fasl-integer (fasdump-block-shared-count block) output-port)
  (write-fasl-integer (queue-length (fasdump-block-types block))
                      output-port))

(define (write-block-fasl-item item port index-cell)
  ((enum-case fasdump-item (car item)
     ((REFERENCE)       write-block-fasl-reference)
     ((IMMEDIATE)       write-block-fasl-immediate)
     ((BYTE-VECTOR)     write-block-fasl-byte-vector)
     ((OBJECT)          write-block-fasl-object))
   (cdr item)
   port
   index-cell))

(define (write-block-fasl-reference descriptor port index-cell)
  index-cell
  (write-octet (enum fasl-header REFERENCE) port)
  (write-fasl-integer (fasdump-descriptor-index descriptor)
                      port))

(define (write-block-fasl-immediate encoded-type port index-cell)
  index-cell
  (write-octet (enum fasl-header IMMEDIATE) port)
  (write-fasl-integer encoded-type port))

(define (write-block-fasl-byte-vector bytev port index-cell)
  index-cell
  (write-block bytev 0 (byte-vector-length bytev)
               port))

(define (write-block-fasl-object descriptor port index-cell)
  (write-octet (cond ((fasdump-descriptor-shared? descriptor)
                      (set-fasdump-descriptor-index!
                       descriptor
                       (let ((index (cell-ref index-cell)))
                         (cell-set! index-cell (+ index 1))
                         index))
                      (enum fasl-header SHARED-OBJECT))
                     (else
                      (enum fasl-header UNSHARED-OBJECT)))
               port)
  (write-fasl-integer (fasdump-descriptor-type descriptor)
                      port))

;;;; Queues

(define (make-queue)
  (let ((cell (cons 'sentinel '())))
    (cons cell cell)))

(define (queue-head queue) (provisional-car queue))
(define (queue-tail queue) (provisional-cdr queue))
(define (set-queue-tail! queue tail) (provisional-set-cdr! queue tail))

(define (enqueue! queue item)
  (let ((cell (cons item '())))
    (provisional-set-cdr! (queue-tail queue) cell)
    (set-queue-tail! queue cell)))

(define (maybe-enqueue! queue item)
  (let loop ((link (queue-head queue))
             (index 0))
    (let ((next (provisional-cdr link)))
      (cond ((null? next)
             (enqueue! queue item)
             index)
            ((eq? (car next) item)
             index)
            (else
             (loop next (+ index 1)))))))

(define (queue-length queue)
  (length (cdr (queue-head queue))))

(define (walk-queue queue proc)
  (for-each proc (provisional-cdr (queue-head queue))))

(define (walk-queue! queue proc)
  (for-each proc
            (let* ((head (queue-head queue))
                   (list (provisional-cdr head)))
              (provisional-set-cdr! head '())
              (set-queue-tail! queue head)
              list)))

;;;; Initialization

(initialize-fasdump-ports!)
(initialize-block-fasdumper-type!)