<commit_before>#lang scheme/base
(require compiler/zo-parse
         scheme/match)

(provide zo-marshal)

;; Doesn't write as compactly as MzScheme, since list and pair sequences
;; are not compated, and symbols are not written in short form

(define (zo-marshal top)
  (match top
    [(struct compilation-top (max-let-depth prefix form))
     (let ([encountered (make-hasheq)]
           [shared (make-hasheq)])
       (let ([visit (lambda (v) 
                      (if (hash-ref shared v #f)
                          #f
                          (if (hash-ref encountered v #f)
                              (begin
                                (hash-set! shared v (add1 (hash-count shared)))
                                #f)
                              (begin
                                (hash-set! encountered v #t)
                                #t))))])
         (traverse-prefix prefix visit)
         (traverse-form form visit))
       (let* ([s (open-output-bytes)]
              [out (make-out s (lambda (v) (hash-ref shared v #f)))]
              [offsets
               (map (lambda (v)
                      (let ([v (cdr v)])
                        (begin0
                         (file-position s)
                         (out-anything v (make-out
                                          s
                                          (let ([skip? #t])
                                            (lambda (v2)
                                              (if (and skip? (eq? v v2))
                                                  (begin
                                                    (set! skip? #f)
                                                    #f)
                                                  (hash-ref shared v2 #f)))))))))
                    (sort (hash-map shared (lambda (k v) (cons v k)))
                          <
                          #:key car))]
              [post-shared (file-position s)]
              [all-short? (post-shared . < . #xFFFF)])
         (out-data (list* max-let-depth prefix (protect-quote form)) out)
         (let ([res (get-output-bytes s)])
           (bytes-append #"#~"
                         (bytes (string-length (version)))
                         (string->bytes/latin-1 (version))
                         (int->bytes (add1 (hash-count shared)))
                         (bytes (if all-short?
                                    1
                                    0))
                         (apply
                          bytes-append
                          (map (lambda (o)
                                 (integer->integer-bytes o
                                                         (if all-short? 2 4)
                                                         #f
                                                         #f))
                               offsets))
                         (int->bytes post-shared)
                         (int->bytes (bytes-length res))
                         res))))]))

;; ----------------------------------------

(define (traverse-prefix a-prefix visit)
  (match a-prefix
    [(struct prefix (num-lifts toplevels stxs))
     (for-each (lambda (stx) (traverse-toplevel stx visit)) toplevels)
     (for-each (lambda (stx) (traverse-stx stx visit)) stxs)]))

(define (traverse-module mod-form visit)
  (match mod-form
    [(struct mod (name self-modidx prefix provides requires body syntax-body unexported 
                       max-let-depth dummy lang-info internal-context))
     (traverse-data name visit)
     (traverse-data self-modidx visit)
     (traverse-prefix prefix visit)
     (for-each (lambda (f) (map (lambda (v) (traverse-data v visit)) (cdr f))) requires)
     (for-each (lambda (f) (traverse-form f prefix)) body)
     (for-each (lambda (f) (traverse-form f prefix)) syntax-body)
     (traverse-data lang-info visit)
     (traverse-data internal-context visit)]))

(define (traverse-toplevel tl visit)
  (match tl
    [#f (void)]
    [(? symbol?) (traverse-data tl visit)]
    [(struct global-bucket (name)) 
     (void)]<commit_msg>zo-marshal patch from Jay<commit_after>#lang scheme/base
(require compiler/zo-parse
         scheme/match)

(provide zo-marshal)

;; Doesn't write as compactly as MzScheme, since list and pair sequences
;; are not compacted, and symbols are not written in short form

(define (zo-marshal top)
  (match top
    [(struct compilation-top (max-let-depth prefix form))
     (let ([encountered (make-hasheq)]
           [shared (make-hasheq)])
       (let ([visit (lambda (v) 
                      (if (hash-ref shared v #f)
                          #f
                          (if (hash-ref encountered v #f)
                              (begin
                                (hash-set! shared v (add1 (hash-count shared)))
                                #f)
                              (begin
                                (hash-set! encountered v #t)
                                #t))))])
         (traverse-prefix prefix visit)
         (traverse-form form visit))
       (let* ([s (open-output-bytes)]
              [out (make-out s (lambda (v) (hash-ref shared v #f)))]
              [offsets
               (map (lambda (v)
                      (let ([v (cdr v)])
                        (begin0
                         (file-position s)
                         (out-anything v (make-out
                                          s
                                          (let ([skip? #t])
                                            (lambda (v2)
                                              (if (and skip? (eq? v v2))
                                                  (begin
                                                    (set! skip? #f)
                                                    #f)
                                                  (hash-ref shared v2 #f)))))))))
                    (sort (hash-map shared (lambda (k v) (cons v k)))
                          <
                          #:key car))]
              [post-shared (file-position s)]
              [all-short? (post-shared . < . #xFFFF)])
         (out-data (list* max-let-depth prefix (protect-quote form)) out)
         (let ([res (get-output-bytes s)])
           (bytes-append #"#~"
                         (bytes (string-length (version)))
                         (string->bytes/latin-1 (version))
                         (int->bytes (add1 (hash-count shared)))
                         (bytes (if all-short?
                                    1
                                    0))
                         (apply
                          bytes-append
                          (map (lambda (o)
                                 (integer->integer-bytes o
                                                         (if all-short? 2 4)
                                                         #f
                                                         #f))
                               offsets))
                         (int->bytes post-shared)
                         (int->bytes (bytes-length res))
                         res))))]))

;; ----------------------------------------

(define (traverse-prefix a-prefix visit)
  (match a-prefix
    [(struct prefix (num-lifts toplevels stxs))
     (for-each (lambda (stx) (traverse-toplevel stx visit)) toplevels)
     (for-each (lambda (stx) (traverse-stx stx visit)) stxs)]))

(define (traverse-module mod-form visit)
  (match mod-form
    [(struct mod (name self-modidx prefix provides requires body syntax-body unexported 
                       max-let-depth dummy lang-info internal-context))
     (traverse-data name visit)
     (traverse-data self-modidx visit)
     (traverse-prefix prefix visit)
     (for-each (lambda (f) (map (lambda (v) (traverse-data v visit)) (cdr f))) requires)
     (for-each (lambda (f) (traverse-form f visit)) body)
     (for-each (lambda (f) (traverse-form f visit)) syntax-body)
     (traverse-data lang-info visit)
     (traverse-data internal-context visit)]))

(define (traverse-toplevel tl visit)
  (match tl
    [#f (void)]
    [(? symbol?) (traverse-data tl visit)]
    [(struct global-bucket (name)) 
     (void)]
{'fraction_non_alphanumeric': 0.1186976066091605, 'fraction_numerical': 0.002672822257319888, 'mean_word_length': 0.9821815555020467, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 13, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 48, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5372166', 'n_tokens_mistral': 2083, 'n_tokens_neox': 1987, 'n_words': 584}