From 0f1088a150a319f9e8b69ae546c141878c73db42 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 29 Jun 2018 08:29:09 -0600 Subject: [PATCH] cs: add cache for JIT mode When linklets are compiled in JIT mode and a called procedure is to be compiled on demand, consult a cache of compiled fragments (by default, "jit.sqlite" in the addons directory) and either use an existing compiled fragment or add to the cache after compiling. Results for this initial implementation suggests that the idea is workable. With the cache, starting a JIT-mode program a second time is almost as fast as non-JIT mode (i.e., directly loading machine code). Some refinements are needed: limiting the size of the JIT-fragment cache, better contention handling, and better inlining of structure operations in JIT mode (which may be useful to cross-linklet optimization in non-JIT mode, too). --- racket/src/cs/Makefile | 7 +- racket/src/cs/README.txt | 16 +- racket/src/cs/linklet.sls | 608 ++++----------------------- racket/src/cs/linklet/annotation.ss | 65 +++ racket/src/cs/linklet/db.ss | 266 ++++++++++++ racket/src/cs/linklet/performance.ss | 76 ++++ racket/src/cs/linklet/read.ss | 188 +++++++++ racket/src/cs/linklet/write.ss | 176 ++++++++ 8 files changed, 876 insertions(+), 526 deletions(-) create mode 100644 racket/src/cs/linklet/annotation.ss create mode 100644 racket/src/cs/linklet/db.ss create mode 100644 racket/src/cs/linklet/performance.ss create mode 100644 racket/src/cs/linklet/read.ss create mode 100644 racket/src/cs/linklet/write.ss diff --git a/racket/src/cs/Makefile b/racket/src/cs/Makefile index 3135fa2ae2..db44c75d8b 100644 --- a/racket/src/cs/Makefile +++ b/racket/src/cs/Makefile @@ -105,7 +105,12 @@ expander-rktl: linklet-demo: $(BUILDDIR)linklet.so $(SCHEME) $(LINKLET_DEPS) $(BUILDDIR)linklet.so demo/linklet.ss -$(BUILDDIR)linklet.so: linklet.sls $(LINKLET_DEPS) $(COMPILE_FILE_DEPS) +LINKLET_SRCS = linklet/read.ss \ + linklet/write.ss \ + linklet/performance.ss \ + linklet/db.ss + +$(BUILDDIR)linklet.so: linklet.sls $(LINKLET_SRCS) $(LINKLET_DEPS) $(COMPILE_FILE_DEPS) $(COMPILE_FILE) linklet.sls $(LINKLET_DEPS) diff --git a/racket/src/cs/README.txt b/racket/src/cs/README.txt index add2ee8870..335591f0c4 100644 --- a/racket/src/cs/README.txt +++ b/racket/src/cs/README.txt @@ -71,21 +71,29 @@ Racket on Chez Scheme currently supports two modes: Select this mode by seting the `PLT_CS_MACH` environment variable, but it's currently the default. + Set `PLT_CS_COMPILE_LIMIT` to set the maximum size of forms to + compile before falling back to interpreted "bytecode". The default + is 10000. + * JIT mode --- The compiled form of a module is an S-expression where individual `lambda`s are compiled on demand. Compiled ".zo" files in this format are written to a "cs" subdirectory of "compiled". Select this mode by seting the `PLT_CS_JIT` environment variable. + S-expressions fragments are hashed at compilation time, so that + the hash for each fragment is stored in the ".zo" file. At JIT + time, the hash is used to consult and/or update a cache + (implemented as an SQLite database) of machine-code forms. Set the + `PLT_JIT_CACHE` environment variable to change the cache file, or + set the environment variable to empty to disable the cache. + Set the `PLT_ZO_PATH` environment variable to override the path used for ".zo" files. For example, you may want to preserve a normal build while also building in machine-code mode with `PLT_CS_DEBUG` set, in which case setting `PLT_ZO_PATH` to something like "a6osx-debug" could be a good idea. -In machine-code code, set `PLT_CS_COMPILE_LIMIT` to set the maximum -size of forms to compile. The default is 10000. - Running ------- @@ -146,6 +154,8 @@ Files in this directory: structures, immutable hash tables, structs, delimited continuations, engines, impersonators, etc. + linklet/*.ss - Parts of "linklet.sls" (via `include`). + compiled/*.rktl (generated) - A Racket library (e.g., to implement regexps) that has been fully macro expanded and flattened into a linklet from its source in "../*". A linklet's only diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 4eda17b820..bbaa92ead0 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -66,6 +66,8 @@ path? complete-path? path->string + path->bytes + bytes->path string->bytes/utf-8 bytes->string/utf-8 prop:custom-write @@ -76,7 +78,14 @@ get-output-bytes file-position current-logger - log-message) + log-message + sha1-bytes + environment-variables-ref + current-environment-variables + find-system-path + build-path) + (only (thread) + current-process-milliseconds) (regexp) (schemify)) @@ -95,6 +104,17 @@ n)))) 10000))) + (define no-future-jit-db? (getenv "PLT_NO_FUTURE_JIT_CACHE")) ; => don't calculate key for cache + (define jit-db-path (let ([bstr (environment-variables-ref + (|#%app| current-environment-variables) + (string->utf8 "PLT_JIT_CACHE"))]) + (cond + [(equal? bstr '#vu8()) #f] ; empty value disables the JIT cache + [(not bstr) + (build-path (find-system-path 'addon-dir) + "cs-jit.sqlite")] + [else (bytes->path bstr)]))) + ;; For "main.sps" to select the default ".zo" directory name: (define platform-independent-zo-mode? (eq? linklet-compilation-mode 'jit)) @@ -138,76 +158,11 @@ (correlated->annotation v)))))))) v])) - (define region-times (make-eq-hashtable)) - (define region-gc-times (make-eq-hashtable)) - (define region-counts (make-eq-hashtable)) - (define region-memories (make-eq-hashtable)) - (define current-start-time '()) - (define current-gc-start-time '()) - (define-syntax performance-region - (syntax-rules () - [(_ label e ...) (measure-performance-region label (lambda () e ...))])) - (define (measure-performance-region label thunk) - (cond - [measure-performance? - (set! current-start-time (cons (current-inexact-milliseconds) current-start-time)) - (set! current-gc-start-time (cons (current-gc-milliseconds) current-gc-start-time)) - (begin0 - (thunk) - (let ([delta (- (current-inexact-milliseconds) (car current-start-time))] - [gc-delta (- (current-gc-milliseconds) (car current-gc-start-time))]) - (hashtable-update! region-times label (lambda (v) (+ v delta)) 0) - (hashtable-update! region-gc-times label (lambda (v) (+ v gc-delta)) 0) - (hashtable-update! region-counts label add1 0) - (set! current-start-time (cdr current-start-time)) - (set! current-gc-start-time (cdr current-gc-start-time)) - (let loop ([l current-start-time] [gc-l current-gc-start-time]) - (unless (null? l) - (set-car! l (+ (car l) delta)) - (set-car! gc-l (+ (car gc-l) gc-delta)) - (loop (cdr l) (cdr gc-l))))))] - [else (thunk)])) - (define (add-performance-memory! label delta) - (when measure-performance? - (hashtable-update! region-memories label (lambda (v) (+ v delta)) 0))) - (define (linklet-performance-init!) - (hashtable-set! region-times 'boot - (let ([t (sstats-cpu (statistics))]) - (+ (* 1000.0 (time-second t)) - (/ (time-nanosecond t) 1000000.0))))) - (define (linklet-performance-report!) - (when measure-performance? - (let ([total 0]) - (define (pad v w) - (let ([s (chez:format "~a" v)]) - (string-append (make-string (max 0 (- w (string-length s))) #\space) - s))) - (define (report label n n-extra units extra) - (chez:printf ";; ~a: ~a~a ~a~a\n" - (pad label 15) - (pad (round (inexact->exact n)) 5) - n-extra - units - extra)) - (define (ht->sorted-list ht) - (list-sort (lambda (a b) (< (cdr a) (cdr b))) - (hash-table-map ht cons))) - (for-each (lambda (p) - (let ([label (car p)] - [n (cdr p)]) - (set! total (+ total n)) - (report label n - (chez:format " [~a]" (pad (hashtable-ref region-gc-times label 0) 5)) - 'ms - (let ([c (hashtable-ref region-counts label 0)]) - (if (zero? c) - "" - (chez:format " ; ~a times" c)))))) - (ht->sorted-list region-times)) - (report 'total total "" 'ms "") - (chez:printf ";;\n") - (for-each (lambda (p) (report (car p) (/ (cdr p) 1024 1024) "" 'MB "")) - (ht->sorted-list region-memories))))) + (include "linklet/write.ss") + (include "linklet/read.ss") + (include "linklet/annotation.ss") + (include "linklet/performance.ss") + (include "linklet/db.ss") ;; `compile`, `interpret`, etc. have `dynamic-wind`-based state ;; that need to be managed correctly when swapping Racket @@ -273,8 +228,30 @@ 'outer ((load-compiled-from-port i))))) + (define-values (lookup-code insert-code delete-code) + (let ([get-procs!-maker + (lambda (retry) + (lambda args + (let-values ([(lookup insert delete) (get-code-database-procedures)]) + (set! lookup-code lookup) + (set! insert-code insert) + (set! delete-code delete) + (apply retry args))))]) + (values (get-procs!-maker (lambda (hash) (lookup-code hash))) + (get-procs!-maker (lambda (hash code) (insert-code hash code))) + (get-procs!-maker (lambda (hash) (delete-code hash)))))) + + (define (add-code-hash a) + (cond + [no-future-jit-db? a] + [else + ;; Combine an annotation with a hash code in a vector + (let-values ([(o get) (open-bytevector-output-port)]) + (fasl-write (cons (version) a) o) + (vector (sha1-bytes (get)) a))])) + (define-record-type wrapped-code - (fields (mutable content) ; bytevector for 'lambda mode; annotation for 'jit mode + (fields (mutable content) ; bytevector for 'lambda mode; annotation or (vector hash annotation) for 'jit mode arity-mask name) (nongenerative #{wrapped-code p6o2m72rgmi36pm8vy559b-0})) @@ -285,17 +262,38 @@ f (performance-region 'on-demand - (cond - [(bytevector? f) - (let* ([f (code-from-bytevector f)]) - (wrapped-code-content-set! wc f) - f)] - [else - (let ([f (compile* f)]) + (let ([f (if (and (vector? f) + (or (not jit-db-path) + (wrong-jit-db-thread?))) + (vector-ref f 1) + f)]) + (cond + [(bytevector? f) + (let* ([f (code-from-bytevector f)]) + (wrapped-code-content-set! wc f) + f)] + [(vector? f) (when jit-demand-on? - (show "JIT demand" (strip-nested-annotations (wrapped-code-content wc)))) - (wrapped-code-content-set! wc f) - f)]))))) + (show "JIT demand" (strip-nested-annotations (vector-ref f 1)))) + (let* ([hash (vector-ref f 0)] + [code (lookup-code hash)]) + (cond + [code + (let* ([f (eval-from-bytevector code 'compile)]) + (wrapped-code-content-set! wc f) + f)] + [else + (let ([code (compile-to-bytevector (vector-ref f 1) 'compile)]) + (insert-code hash code) + (let* ([f (eval-from-bytevector code 'compile)]) + (wrapped-code-content-set! wc f) + f))]))] + [else + (let ([f (compile* f)]) + (when jit-demand-on? + (show "JIT demand" (strip-nested-annotations (wrapped-code-content wc)))) + (wrapped-code-content-set! wc f) + f)])))))) (define (jitified-extract-closed wc) (let ([f (wrapped-code-content wc)]) @@ -418,9 +416,12 @@ [(jit) ;; Preserve annotated `lambda` source for on-demand compilation: (lambda (expr arity-mask name) - (make-wrapped-code (correlated->annotation (xify expr)) - arity-mask - name))] + (let ([a (correlated->annotation (xify expr))]) + (make-wrapped-code (if serializable? + (add-code-hash a) + a) + arity-mask + name)))] [else ;; Compile an individual `lambda`: (lambda (expr arity-mask name) @@ -782,443 +783,6 @@ (define (make-instance-variable-reference vr v) (make-variable-reference (variable-reference-instance vr) v)) - ;; ---------------------------------------- - - (define (write-linklet-bundle b port mode) - ;; Various tools expect a particular header: - ;; "#~" - ;; length of version byte string (< 64) as one byte - ;; version byte string - ;; "B" - ;; 20 bytes of SHA-1 hash - (write-bytes '#vu8(35 126) port) - (let ([vers (string->bytes/utf-8 (version))]) - (write-bytes (bytes (bytes-length vers)) port) - (write-bytes vers port)) - (write-bytes '#vu8(66) port) - (write-bytes (make-bytes 20 0) port) - ;; The rest is whatever we want. We'll simply fasl the bundle. - (let-values ([(o get) (open-bytevector-output-port)]) - (fasl-write* b o) - (let ([bstr (get)]) - (write-int (bytes-length bstr) port) - (write-bytes bstr port)))) - - (define (linklet-bundle->bytes b) - (let ([o (open-output-bytes)]) - (write-linklet-bundle b o #t) - (get-output-bytes o))) - - (define (write-linklet-directory ld port mode) - ;; Various tools expect a particular header: - ;; "#~" - ;; length of version byte string (< 64) as one byte - ;; version byte string - ;; "D" - ;; bundle count as 4-byte integer - ;; binary tree: - ;; bundle-name length as 4-byte integer - ;; bundle name [encoding decribed below] - ;; bundle offset as 4-byte integer - ;; bundle size as 4-byte integer - ;; left-branch offset as 4-byte integer - ;; right-branch offset as 4-byte integer - ;; A bundle name corresponds to a list of symbols. Each symbol in the list is - ;; prefixed with either: its length as a byte if less than 255; 255 followed by - ;; a 4-byte integer for the length. - (write-bytes '#vu8(35 126) port) - (let ([vers (string->bytes/utf-8 (version))]) - (write-bytes (bytes (bytes-length vers)) port) - (write-bytes vers port) - (write-bytes '#vu8(68) port) - ;; Flatten a directory of bundles into a vector of pairs, where - ;; each pair has the encoded bundle name and the bundle bytes - (let* ([bundles (list->vector (flatten-linklet-directory ld '() '()))] - [len (vector-length bundles)] - [initial-offset (+ 2 ; "#~" - 1 ; version length - (bytes-length vers) - 1 ; D - 4)]) ; bundle count - (write-int len port) ; bundle count - (chez:vector-sort! (lambda (a b) (bytesbytes value)) - accum) - #t)] - [else - (loop (hash-iterate-next ht i) - (flatten-linklet-directory value (cons key rev-name-prefix) accum) - saw-bundle?)]))])))) - - ;; Encode a bundle name (as a reversed list of symbols) as a single - ;; byte string - (define (encode-name rev-name) - (define (encode-symbol s) - (let* ([bstr (string->bytes/utf-8 (symbol->string s))] - [len (bytes-length bstr)]) - (if (< len 255) - (list (bytes len) bstr) - (list (bytes 255) (integer->integer-bytes len 4 #f #f) bstr)))) - (let loop ([rev-name rev-name] [accum '()]) - (cond - [(null? rev-name) (apply bytes-append accum)] - [else - (loop (cdr rev-name) (append (encode-symbol (car rev-name)) - accum))]))) - - ;; Figure out how big the binary tree will be, which depends - ;; on the size of bundle-name byte strings - (define (compute-btree-size bundles len) - (let loop ([i 0] [size 0]) - (if (= i len) - size - (let ([nlen (bytes-length (car (vector-ref bundles i)))]) - ;; 5 numbers: name length, bundle offset, bundles size, lef, and right - (loop (fx1+ i) (+ size nlen (* 5 4))))))) - - ;; Compute the offset where each node in the binary tree will reside - ;; relative to the start of the bundle directory's "#~" - (define (compute-btree-node-offsets bundles len initial-offset) - (let ([node-offsets (make-vector len)]) - (let loop ([lo 0] [hi len] [offset initial-offset]) - (cond - [(= lo hi) offset] - [else - (let* ([mid (quotient (+ lo hi) 2)]) - (vector-set! node-offsets mid offset) - (let* ([nlen (bytes-length (car (vector-ref bundles mid)))] - [offset (+ offset 4 nlen 4 4 4 4)]) - (let ([offset (loop lo mid offset)]) - (loop (add1 mid) hi offset))))])) - node-offsets)) - - ;; Compute the offset where each bundle will reside relative - ;; to the start of the bundle directory's "#~" - (define (compute-bundle-offsets bundles len offset) - (let ([bundle-offsets (make-vector len)]) - (let loop ([i 0] [offset offset]) - (unless (= i len) - (vector-set! bundle-offsets i offset) - (loop (fx1+ i) (+ offset (bytes-length (cdr (vector-ref bundles i))))))) - bundle-offsets)) - - ;; Write the binary tree for the directory: - (define (write-directory-btree bundles node-offsets bundle-offsets len port) - (let loop ([lo 0] [hi len]) - (cond - [(= lo hi) (void)] - [else - (let* ([mid (quotient (+ lo hi) 2)] - [p (vector-ref bundles mid)] - [nlen (bytes-length (car p))]) - (write-int nlen port) - (write-bytes (car p) port) - (write-int (vector-ref bundle-offsets mid) port) - (write-int (bytes-length (cdr p)) port) - (cond - [(> mid lo) - (let ([left (quotient (+ lo mid) 2)]) - (write-int (vector-ref node-offsets left) port))] - [else - (write-int 0 port)]) - (cond - [(< (fx1+ mid) hi) - (let ([right (quotient (+ (fx1+ mid) hi) 2)]) - (write-int (vector-ref node-offsets right) port))] - [else - (write-int 0 port)]) - (loop lo mid) - (loop (fx1+ mid) hi))]))) - - (define (write-int n port) - (write-bytes (integer->integer-bytes n 4 #f #f) port)) - - ;; -------------------------------------------------- - - (define (read-compiled-linklet in) - (read-compiled-linklet-or-directory in #t)) - - (define (read-compiled-linklet-or-directory in initial?) - ;; `#~` has already been read - (let* ([start-pos (- (file-position in) 2)] - [vers-len (min 63 (read-byte in))] - [vers (read-bytes vers-len in)]) - (unless (equal? vers (string->bytes/utf-8 (version))) - (raise-arguments-error 'read-compiled-linklet - "version mismatch" - "expected" (version) - "found" (bytes->string/utf-8 vers #\?) - "in" (let ([n (object-name in)]) - (if (path? n) - (unquoted-printing-string - (path->string n)) - in)))) - (let ([tag (read-byte in)]) - (cond - [(equal? tag (char->integer #\B)) - (let ([sha-1 (read-bytes 20 in)]) - (let ([len (read-int in)]) - (let ([bstr (read-bytes len in)]) - (let ([b (fasl-read (open-bytevector-input-port bstr))]) - (add-hash-code (adjust-linklet-bundle-laziness - (if initial? - (strip-submodule-references b) - b)) - sha-1)))))] - [(equal? tag (char->integer #\D)) - (unless initial? - (raise-argument-error 'read-compiled-linklet - "expected a linklet bundle")) - (read-bundle-directory in start-pos)] - [else - (raise-arguments-error 'read-compiled-linklet - "expected a `B` or `D`")])))) - - (define (read-int in) - (integer-bytes->integer (read-bytes 4 in) #f #f)) - - (define (read-bundle-directory in pos) - (let ([count (read-int in)]) - (let ([position-to-name - (let loop ([count count] [accum (hasheqv)]) - (cond - [(zero? count) accum] - [else - (let ([bstr (read-bytes (read-int in) in)]) - (let* ([offset (read-int in)] - [len (read-int in)]) - (read-int in) ; left - (read-int in) ; right - (loop (fx1- count) - (hash-set accum offset bstr))))]))]) - (let loop ([count count] [accum '()]) - (cond - [(zero? count) - (list->bundle-directory accum)] - [else - (let ([name (hash-ref position-to-name (- (file-position in) pos) #f)]) - (unless name - (raise-arguments-error 'read-compiled-linklet - "bundle not at an expected file position")) - (let ([bstr (read-bytes 2 in)]) - (let ([bundle - (cond - [(equal? '#vu8(35 126) bstr) - (read-compiled-linklet in)] - [(equal? '#vu8(35 102) bstr) - #f] - [else - (raise-arguments-error 'read-compiled-linklet - "expected a `#~` or `#f` for a bundle")])]) - (loop (fx1- count) - (cons (cons (decode-name name 0) bundle) accum)))))]))))) - - (define (decode-name bstr pos) - (let ([blen (bytes-length bstr)] - [bad-bundle (lambda () - (raise-arguments-error 'read-compiled-linklet - "malformed bundle"))]) - (cond - [(= pos blen) - '()] - [(> pos blen) (bad-bundle)] - [else - (let ([len (bytes-ref bstr pos)]) - (when (> (+ pos len 1) blen) (bad-bundle)) - (if (= len 255) - (let ([len (integer-bytes->integer bstr #f #f (fx1+ pos) (fx+ pos 5))]) - (when (> (+ pos len 1) blen) (bad-bundle)) - (cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx+ pos 5) (+ pos 5 len)) #\?)) - (decode-name bstr (+ pos 5 len)))) - (cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx1+ pos) (+ pos 1 len)) #\?)) - (decode-name bstr (+ pos 1 len)))))]))) - - ;; Convert a post-order list into a tree - (define (list->bundle-directory l) - ;; The bundles list is in post-order, so we can build directories - ;; bottom-up - (let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)]) - (when (null? l) - (raise-arguments-error 'read-compiled-linklet - "invalid bundle sequence")) - (let* ([p (car l)] - [path (car p)] - [v (cdr p)] - [len (length path)]) - (when (< len prev-len) - (raise-arguments-error 'read-compiled-linklet - "invalid bundle sequence")) - (let sloop ([prev-len prev-len] [stack stack] [accum accum]) - (cond - [(> len (fx1+ prev-len)) - (sloop (fx1+ prev-len) - (cons accum stack) - (hasheq))] - [else - (let ([path (list-tail path (fxmax 0 (fx1- prev-len)))]) - (cond - [(= len prev-len) - (let ([accum (if v - (hash-set accum #f v) - accum)]) - (if (zero? len) - (make-linklet-directory accum) - (loop (cdr l) - (fx1- prev-len) - (cdr stack) - (hash-set (car stack) (car path) (make-linklet-directory accum)))))] - [else - (let ([path (if (positive? prev-len) - (cdr path) - path)]) - (loop (cdr l) - prev-len - stack - (hash-set accum - (car path) - (make-linklet-directory (if v - (hasheq #f v) - (hasheq))))))]))]))))) - - ;; When a bundle is loaded by itself, remove any 'pre and 'post - ;; submodule descriptions: - (define (strip-submodule-references b) - (make-linklet-bundle (hash-remove (hash-remove (linklet-bundle-hash b) 'pre) 'post))) - - ;; If the bundle has a non-zero hash code, record it with the - ;; 'hash-code key to enable module caching - (define (add-hash-code b sha-1) - (if (bytevector=? sha-1 '#vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) - b - (make-linklet-bundle (hash-set (linklet-bundle-hash b) 'hash-code sha-1)))) - - (define read-on-demand-source - (make-parameter #f - (lambda (v) - (unless (or (eq? v #t) (eq? v #f) (and (path? v) - (complete-path? v))) - (raise-argument-error 'read-on-demand-source - "(or/c #f #t (and/c path? complete-path?))" - v)) - v))) - - (define (adjust-linklet-bundle-laziness b) - (make-linklet-bundle - (let ([ht (linklet-bundle-hash b)]) - (let loop ([i (hash-iterate-first ht)]) - (cond - [(not i) (hasheq)] - [else - (let-values ([(key val) (hash-iterate-key+value ht i)]) - (hash-set (loop (hash-iterate-next ht i)) - key - (if (linklet? val) - (adjust-linklet-laziness val) - val)))]))))) - - (define (adjust-linklet-laziness linklet) - (set-linklet-code linklet - (linklet-code linklet) - (if (|#%app| read-on-demand-source) - 'faslable - 'faslable-strict))) - - ;; -------------------------------------------------- - - (define (correlated->annotation v) - (let-values ([(e stripped-e) (correlated->annotation* v)]) - e)) - - (define (correlated->annotation* v) - (cond - [(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v))] - [(d stripped-d) (correlated->annotation* (cdr v))]) - (if (and (eq? a (car v)) - (eq? d (cdr v))) - (values v v) - (values (cons a d) - (cons stripped-a stripped-d))))] - [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))]) - (let ([name (correlated-property v 'inferred-name)]) - (define (add-name e) - (if (and name (not (void? name))) - `(|#%name| ,name ,e) - e)) - (values (add-name (transfer-srcloc v e stripped-e)) - (add-name stripped-e))))] - ;; correlated will be nested only in pairs with current expander - [else (values v v)])) - - (define (transfer-srcloc v e stripped-e) - (let ([src (correlated-source v)] - [pos (correlated-position v)] - [line (correlated-line v)] - [column (correlated-column v)] - [span (correlated-span v)]) - (if (and pos span (or (path? src) (string? src))) - (let ([pos (sub1 pos)]) ; Racket positions are 1-based; host Scheme positions are 0-based - (make-annotation e - (if (and line column) - ;; Racket columns are 0-based; host-Scheme columns are 1-based - (make-source-object (source->sfd src) pos (+ pos span) line (add1 column)) - (make-source-object (source->sfd src) pos (+ pos span))) - stripped-e)) - e))) - - (define sfd-cache (make-weak-hash)) - - (define (source->sfd src) - (or (hash-ref sfd-cache src #f) - (let ([str (if (path? src) - (path->string src) - src)]) - ;; We'll use a file-position object in source objects, so - ;; the sfd checksum doesn't matter - (let ([sfd (source-file-descriptor str 0)]) - (hash-set! sfd-cache src sfd) - sfd)))) - - ;; -------------------------------------------------- - - (define (strip-nested-annotations s) - (cond - [(annotation? s) (annotation-stripped s)] - [(pair? s) - (let ([a (strip-nested-annotations (car s))] - [d (strip-nested-annotations (cdr s))]) - (if (and (eq? a (car s)) (eq? d (cdr s))) - s - (cons a d)))] - [else s])) - ;; -------------------------------------------------- (define compile-enforce-module-constants diff --git a/racket/src/cs/linklet/annotation.ss b/racket/src/cs/linklet/annotation.ss new file mode 100644 index 0000000000..62c31f7b44 --- /dev/null +++ b/racket/src/cs/linklet/annotation.ss @@ -0,0 +1,65 @@ +(define (correlated->annotation v) + (let-values ([(e stripped-e) (correlated->annotation* v)]) + e)) + +(define (correlated->annotation* v) + (cond + [(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v))] + [(d stripped-d) (correlated->annotation* (cdr v))]) + (if (and (eq? a (car v)) + (eq? d (cdr v))) + (values v v) + (values (cons a d) + (cons stripped-a stripped-d))))] + [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))]) + (let ([name (correlated-property v 'inferred-name)]) + (define (add-name e) + (if (and name (not (void? name))) + `(|#%name| ,name ,e) + e)) + (values (add-name (transfer-srcloc v e stripped-e)) + (add-name stripped-e))))] + ;; correlated will be nested only in pairs with current expander + [else (values v v)])) + +(define (transfer-srcloc v e stripped-e) + (let ([src (correlated-source v)] + [pos (correlated-position v)] + [line (correlated-line v)] + [column (correlated-column v)] + [span (correlated-span v)]) + (if (and pos span (or (path? src) (string? src))) + (let ([pos (sub1 pos)]) ; Racket positions are 1-based; host Scheme positions are 0-based + (make-annotation e + (if (and line column) + ;; Racket columns are 0-based; host-Scheme columns are 1-based + (make-source-object (source->sfd src) pos (+ pos span) line (add1 column)) + (make-source-object (source->sfd src) pos (+ pos span))) + stripped-e)) + e))) + +(define sfd-cache (make-weak-hash)) + +(define (source->sfd src) + (or (hash-ref sfd-cache src #f) + (let ([str (if (path? src) + (path->string src) + src)]) + ;; We'll use a file-position object in source objects, so + ;; the sfd checksum doesn't matter + (let ([sfd (source-file-descriptor str 0)]) + (hash-set! sfd-cache src sfd) + sfd)))) + +;; -------------------------------------------------- + +(define (strip-nested-annotations s) + (cond + [(annotation? s) (annotation-stripped s)] + [(pair? s) + (let ([a (strip-nested-annotations (car s))] + [d (strip-nested-annotations (cdr s))]) + (if (and (eq? a (car s)) (eq? d (cdr s))) + s + (cons a d)))] + [else s])) diff --git a/racket/src/cs/linklet/db.ss b/racket/src/cs/linklet/db.ss new file mode 100644 index 0000000000..de8251cb26 --- /dev/null +++ b/racket/src/cs/linklet/db.ss @@ -0,0 +1,266 @@ + +;; For now, don't try to use the JIT database from multiple threads +(meta-cond + [(threaded?) + (begin + (define original-thread-id (get-thread-id)) + (define (wrong-jit-db-thread?) + (not (eqv? original-thread-id (get-thread-id)))))] + [else + (define (wrong-jit-db-thread?) #f)]) + +(define (db-error who fmt . args) + (let ([str (string-append (symbol->string who) + ": " + (apply #%format fmt args))]) + (log-message root-logger 'error 'jit-db str #f) + #f)) + +(define (no-db-procedures) + (values (lambda (hash) #f) + (lambda (hash code) (void)) + (lambda (hash) (void)))) + +;; Gets Sqlite3-based lookup, insert, and delete on demand, +;; returning the dummy functions from `no-db-procedures` +;; if something goes wrong setting up the database +(define (get-code-database-procedures) + (with-interrupts-disabled + (guard + (exn [else (db-error 'load "could not load sqlite ~s" + (if (message-condition? exn) + (condition-message exn) + exn)) + (no-db-procedures)]) + (let ([ok (begin + ;; FIXME: look in the Racket "lib" directory, first + (case (system-type) + [(macosx) (load-shared-object "libsqlite3.0.dylib")] + [(windows) (load-shared-object "sqlite3.dll")] + [else (load-shared-object "libsqlite3.so.0")]) + (void))]) + (define SQLITE_OPEN_READONLY #x00000001) + (define SQLITE_OPEN_READWRITE #x00000002) + (define SQLITE_OPEN_CREATE #x00000004) + + (define SQLITE_OK 0) + (define SQLITE_CONSTRAINT 19) + (define SQLITE_ROW 100) + (define SQLITE_DONE 101) + + (define SQLITE_TRANSIENT -1) + + (define memcpy_pp (foreign-procedure "(cs)byte-copy" (uptr iptr uptr iptr iptr) void)) + (define memcpy_bp (foreign-procedure "(cs)byte-copy" (u8* iptr uptr iptr iptr) void)) + (define memcpy_pb (foreign-procedure "(cs)byte-copy" (uptr iptr u8* iptr iptr) void)) + (define memcpy_bb (foreign-procedure "(cs)byte-copy" (u8* iptr u8* iptr iptr) void)) + + (define (memcpy dest src len) + (cond + [(bytevector? dest) + (if (bytevector? src) + (memcpy_bb src 0 dest 0 len) + (memcpy_pb src 0 dest 0 len))] + [else + (if (bytevector? src) + (memcpy_bp src 0 dest 0 len) + (memcpy_pp src 0 dest 0 len))])) + + (define sqlite3_open_v2 + (foreign-procedure "sqlite3_open_v2" + (u8* ; path + uptr ; receives a pointer result + int ; flags + uptr) ; VFS + int)) + + (define sqlite3_prepare_v2 + (foreign-procedure "sqlite3_prepare_v2" + (uptr ; db + uptr ; statement string + int ; statement length + uptr ; ptr to result + uptr) ; ptr to leftover statement string + int)) + + (define sqlite3_step + (foreign-procedure "sqlite3_step" + (uptr) ; statement + int)) + + (define sqlite3_reset + (foreign-procedure "sqlite3_reset" + (uptr) ; statement + int)) + + (define sqlite3_clear_bindings + (foreign-procedure "sqlite3_clear_bindings" + (uptr) ; statement + int)) + + (define sqlite3_finalize + (foreign-procedure "sqlite3_finalize" + (uptr) ; statement + int)) + + (define sqlite3_bind_blob + (foreign-procedure "sqlite3_bind_blob" + (uptr ; statement + int ; parameter index + u8* ; data + int ; length + iptr) ; use SQLITE_TRANSIENT + int)) + + (define sqlite3_column_blob + (foreign-procedure "sqlite3_column_blob" + (uptr ; statement + int) ; column + uptr)) + (define sqlite3_column_bytes + (foreign-procedure "sqlite3_column_bytes" + (uptr ; statement + int) ; column + int)) + + (define sqlite3_errstr + (foreign-procedure "sqlite3_errstr" + (int) + string)) + + (define sqlite3_errmsg + (foreign-procedure "sqlite3_errmsg" + (uptr) ; database + string)) + + (define (errstr r) + (sqlite3_errstr r)) + + (define db + (let ([db-ptr (foreign-alloc (foreign-sizeof 'uptr))]) + (define r + (sqlite3_open_v2 (bytes-append (path->bytes jit-db-path) + '#vu8(0)) + db-ptr + (bitwise-ior SQLITE_OPEN_READWRITE + SQLITE_OPEN_CREATE) + 0)) + (let ([db (foreign-ref 'uptr 0 db-ptr)]) + (foreign-free db-ptr) + (cond + [(= r SQLITE_OK) db] + [else (db-error 'open "failed ~s" (errstr r))])))) + + (define (prepare db stmt-str) + (let* ([stmt (string->utf8 stmt-str)] + [stmt-len (bytevector-length stmt)] + [stmt-copy (foreign-alloc stmt-len)] + [s-ptr (foreign-alloc (foreign-sizeof 'uptr))] + [rest-ptr (foreign-alloc (foreign-sizeof 'uptr))]) + (memcpy stmt-copy stmt stmt-len) + (let ([r (sqlite3_prepare_v2 db + stmt-copy + stmt-len + s-ptr + rest-ptr)]) + (let* ([s (foreign-ref 'uptr 0 s-ptr)] + [rest (foreign-ref 'uptr 0 rest-ptr)]) + (foreign-free stmt-copy) + (cond + [(= r SQLITE_OK) + (cond + [(= rest (+ stmt-copy stmt-len)) + ;; Success + s] + [else + (finalize s) + (db-error 'prepare "more than one statement ~s" stmt-str)])] + [else + (db-error 'prepare "error ~s" (errstr r))]))))) + + (define (finalize s) + (define r (sqlite3_finalize s)) + (unless (= r SQLITE_OK) + (db-error 'finalize "error ~s" (errstr r)))) + + (define (step s result-shape) + (define r (sqlite3_step s)) + (cond + [(= r SQLITE_ROW) + (let loop ([result-shape result-shape] [col 0]) + (case result-shape + [(bytes) + (let* ([blob (sqlite3_column_blob s col)] + [len (sqlite3_column_bytes s col)] + [bstr (make-bytevector len)]) + (memcpy bstr blob len) + bstr)] + [(void ignore-constraint) (void)] + [else + (cond + [else (db-error 'step "unrecognized result format ~s" result-shape)])]))] + [(= r SQLITE_DONE) + #f] + [(and (= r SQLITE_CONSTRAINT) + (eq? result-shape 'ignore-constraint)) + ;; Ignore a constraint failure, because we assume it reflects a + ;; lost race trying to insert code for the same hash + (void)] + [else + (db-error 'step "error ~s" (errstr r))])) + + (define initialized-db + (when db + (let ([s (prepare db "SELECT name FROM sqlite_master WHERE type='table' AND name='compiled'")]) + (unless (step s 'void) + (let ([s2 (prepare db "CREATE TABLE compiled (hash blob(24), code blob(1024), PRIMARY KEY (hash))")]) + (step s2 'void) + (finalize s2))) + (finalize s)) + ;; FIXME: this pragma is needed for reasonable performance on Linux, but + ;; we should instead batch updates in `insert` (since it's ok for an + ;; update to get lost, but not ok for the database to be corrupted) + (let ([s (prepare db "PRAGMA synchronous = OFF")]) + (step s 'void) + (finalize s)))) + + (define (check who r) + (unless (= r SQLITE_OK) + (db-error who "error ~s" (errstr r)))) + + (define (bind s pos v) + (check 'bind (sqlite3_bind_blob s pos v (bytevector-length v) SQLITE_TRANSIENT))) + + (define lookup-s (prepare db "SELECT code FROM compiled WHERE hash=$1")) + (define delete-s (prepare db "DELETE FROM compiled WHERE hash=$1")) + (define insert-s (prepare db "INSERT INTO compiled VALUES ($1, $2)")) + + (define (reset s) + (sqlite3_reset s) ; ignore any error, since it's a repeat of recent error + (check 'clear-bindings (sqlite3_clear_bindings s))) + + (define (lookup hash) + (with-interrupts-disabled + (bind lookup-s 1 hash) + (let ([r (step lookup-s 'bytes)]) + (reset lookup-s) + r))) + + (define (insert hash code) + (with-interrupts-disabled + (bind insert-s 1 hash) + (bind insert-s 2 code) + (step insert-s 'ignore-constraint) + (reset insert-s) + (void))) + + (define (delete hash) + (with-interrupts-disabled + (bind delete-s 1 hash) + (step delete-s 'void) + (reset delete-s) + (void))) + + (if db + (values lookup insert delete) + (no-db-procedures)))))) diff --git a/racket/src/cs/linklet/performance.ss b/racket/src/cs/linklet/performance.ss new file mode 100644 index 0000000000..57f5243055 --- /dev/null +++ b/racket/src/cs/linklet/performance.ss @@ -0,0 +1,76 @@ +(define region-times (make-eq-hashtable)) +(define region-gc-times (make-eq-hashtable)) +(define region-counts (make-eq-hashtable)) +(define region-memories (make-eq-hashtable)) + +(define current-start-time '()) +(define current-gc-start-time '()) + +(define-syntax performance-region + (syntax-rules () + [(_ label e ...) (measure-performance-region label (lambda () e ...))])) + +(define (measure-performance-region label thunk) + (cond + [measure-performance? + (set! current-start-time (cons (current-process-milliseconds) current-start-time)) + (set! current-gc-start-time (cons (current-gc-milliseconds) current-gc-start-time)) + (begin0 + (thunk) + (let ([delta (- (current-process-milliseconds) (car current-start-time))] + [gc-delta (- (current-gc-milliseconds) (car current-gc-start-time))]) + (hashtable-update! region-times label (lambda (v) (+ v delta)) 0) + (hashtable-update! region-gc-times label (lambda (v) (+ v gc-delta)) 0) + (hashtable-update! region-counts label add1 0) + (set! current-start-time (cdr current-start-time)) + (set! current-gc-start-time (cdr current-gc-start-time)) + (let loop ([l current-start-time] [gc-l current-gc-start-time]) + (unless (null? l) + (set-car! l (+ (car l) delta)) + (set-car! gc-l (+ (car gc-l) gc-delta)) + (loop (cdr l) (cdr gc-l))))))] + [else (thunk)])) + +(define (add-performance-memory! label delta) + (when measure-performance? + (hashtable-update! region-memories label (lambda (v) (+ v delta)) 0))) + +(define (linklet-performance-init!) + (hashtable-set! region-times 'boot + (let ([t (sstats-cpu (statistics))]) + (+ (* 1000.0 (time-second t)) + (/ (time-nanosecond t) 1000000.0))))) + +(define (linklet-performance-report!) + (when measure-performance? + (let ([total 0]) + (define (pad v w) + (let ([s (chez:format "~a" v)]) + (string-append (make-string (max 0 (- w (string-length s))) #\space) + s))) + (define (report label n n-extra units extra) + (chez:printf ";; ~a: ~a~a ~a~a\n" + (pad label 15) + (pad (round (inexact->exact n)) 5) + n-extra + units + extra)) + (define (ht->sorted-list ht) + (list-sort (lambda (a b) (< (cdr a) (cdr b))) + (hash-table-map ht cons))) + (for-each (lambda (p) + (let ([label (car p)] + [n (cdr p)]) + (set! total (+ total n)) + (report label n + (chez:format " [~a]" (pad (hashtable-ref region-gc-times label 0) 5)) + 'ms + (let ([c (hashtable-ref region-counts label 0)]) + (if (zero? c) + "" + (chez:format " ; ~a times" c)))))) + (ht->sorted-list region-times)) + (report 'total total "" 'ms "") + (chez:printf ";;\n") + (for-each (lambda (p) (report (car p) (/ (cdr p) 1024 1024) "" 'MB "")) + (ht->sorted-list region-memories))))) diff --git a/racket/src/cs/linklet/read.ss b/racket/src/cs/linklet/read.ss new file mode 100644 index 0000000000..bea0ec04d4 --- /dev/null +++ b/racket/src/cs/linklet/read.ss @@ -0,0 +1,188 @@ +(define (read-compiled-linklet in) + (read-compiled-linklet-or-directory in #t)) + +(define (read-compiled-linklet-or-directory in initial?) + ;; `#~` has already been read + (let* ([start-pos (- (file-position in) 2)] + [vers-len (min 63 (read-byte in))] + [vers (read-bytes vers-len in)]) + (unless (equal? vers (string->bytes/utf-8 (version))) + (raise-arguments-error 'read-compiled-linklet + "version mismatch" + "expected" (version) + "found" (bytes->string/utf-8 vers #\?) + "in" (let ([n (object-name in)]) + (if (path? n) + (unquoted-printing-string + (path->string n)) + in)))) + (let ([tag (read-byte in)]) + (cond + [(equal? tag (char->integer #\B)) + (let ([sha-1 (read-bytes 20 in)]) + (let ([len (read-int in)]) + (let ([bstr (read-bytes len in)]) + (let ([b (fasl-read (open-bytevector-input-port bstr))]) + (add-hash-code (adjust-linklet-bundle-laziness + (if initial? + (strip-submodule-references b) + b)) + sha-1)))))] + [(equal? tag (char->integer #\D)) + (unless initial? + (raise-argument-error 'read-compiled-linklet + "expected a linklet bundle")) + (read-bundle-directory in start-pos)] + [else + (raise-arguments-error 'read-compiled-linklet + "expected a `B` or `D`")])))) + +(define (read-int in) + (integer-bytes->integer (read-bytes 4 in) #f #f)) + +(define (read-bundle-directory in pos) + (let ([count (read-int in)]) + (let ([position-to-name + (let loop ([count count] [accum (hasheqv)]) + (cond + [(zero? count) accum] + [else + (let ([bstr (read-bytes (read-int in) in)]) + (let* ([offset (read-int in)] + [len (read-int in)]) + (read-int in) ; left + (read-int in) ; right + (loop (fx1- count) + (hash-set accum offset bstr))))]))]) + (let loop ([count count] [accum '()]) + (cond + [(zero? count) + (list->bundle-directory accum)] + [else + (let ([name (hash-ref position-to-name (- (file-position in) pos) #f)]) + (unless name + (raise-arguments-error 'read-compiled-linklet + "bundle not at an expected file position")) + (let ([bstr (read-bytes 2 in)]) + (let ([bundle + (cond + [(equal? '#vu8(35 126) bstr) + (read-compiled-linklet in)] + [(equal? '#vu8(35 102) bstr) + #f] + [else + (raise-arguments-error 'read-compiled-linklet + "expected a `#~` or `#f` for a bundle")])]) + (loop (fx1- count) + (cons (cons (decode-name name 0) bundle) accum)))))]))))) + +(define (decode-name bstr pos) + (let ([blen (bytes-length bstr)] + [bad-bundle (lambda () + (raise-arguments-error 'read-compiled-linklet + "malformed bundle"))]) + (cond + [(= pos blen) + '()] + [(> pos blen) (bad-bundle)] + [else + (let ([len (bytes-ref bstr pos)]) + (when (> (+ pos len 1) blen) (bad-bundle)) + (if (= len 255) + (let ([len (integer-bytes->integer bstr #f #f (fx1+ pos) (fx+ pos 5))]) + (when (> (+ pos len 1) blen) (bad-bundle)) + (cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx+ pos 5) (+ pos 5 len)) #\?)) + (decode-name bstr (+ pos 5 len)))) + (cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx1+ pos) (+ pos 1 len)) #\?)) + (decode-name bstr (+ pos 1 len)))))]))) + +;; Convert a post-order list into a tree +(define (list->bundle-directory l) + ;; The bundles list is in post-order, so we can build directories + ;; bottom-up + (let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)]) + (when (null? l) + (raise-arguments-error 'read-compiled-linklet + "invalid bundle sequence")) + (let* ([p (car l)] + [path (car p)] + [v (cdr p)] + [len (length path)]) + (when (< len prev-len) + (raise-arguments-error 'read-compiled-linklet + "invalid bundle sequence")) + (let sloop ([prev-len prev-len] [stack stack] [accum accum]) + (cond + [(> len (fx1+ prev-len)) + (sloop (fx1+ prev-len) + (cons accum stack) + (hasheq))] + [else + (let ([path (list-tail path (fxmax 0 (fx1- prev-len)))]) + (cond + [(= len prev-len) + (let ([accum (if v + (hash-set accum #f v) + accum)]) + (if (zero? len) + (make-linklet-directory accum) + (loop (cdr l) + (fx1- prev-len) + (cdr stack) + (hash-set (car stack) (car path) (make-linklet-directory accum)))))] + [else + (let ([path (if (positive? prev-len) + (cdr path) + path)]) + (loop (cdr l) + prev-len + stack + (hash-set accum + (car path) + (make-linklet-directory (if v + (hasheq #f v) + (hasheq))))))]))]))))) + +;; When a bundle is loaded by itself, remove any 'pre and 'post +;; submodule descriptions: +(define (strip-submodule-references b) + (make-linklet-bundle (hash-remove (hash-remove (linklet-bundle-hash b) 'pre) 'post))) + +;; If the bundle has a non-zero hash code, record it with the +;; 'hash-code key to enable module caching +(define (add-hash-code b sha-1) + (if (bytevector=? sha-1 '#vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + b + (make-linklet-bundle (hash-set (linklet-bundle-hash b) 'hash-code sha-1)))) + +(define read-on-demand-source + (make-parameter #f + (lambda (v) + (unless (or (eq? v #t) (eq? v #f) (and (path? v) + (complete-path? v))) + (raise-argument-error 'read-on-demand-source + "(or/c #f #t (and/c path? complete-path?))" + v)) + v))) + +(define (adjust-linklet-bundle-laziness b) + (make-linklet-bundle + (let ([ht (linklet-bundle-hash b)]) + (let loop ([i (hash-iterate-first ht)]) + (cond + [(not i) (hasheq)] + [else + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (hash-set (loop (hash-iterate-next ht i)) + key + (if (linklet? val) + (adjust-linklet-laziness val) + val)))]))))) + +(define (adjust-linklet-laziness linklet) + (set-linklet-code linklet + (linklet-code linklet) + (if (|#%app| read-on-demand-source) + 'faslable + 'faslable-strict))) + diff --git a/racket/src/cs/linklet/write.ss b/racket/src/cs/linklet/write.ss new file mode 100644 index 0000000000..c1677a7564 --- /dev/null +++ b/racket/src/cs/linklet/write.ss @@ -0,0 +1,176 @@ +(define (write-linklet-bundle b port mode) + ;; Various tools expect a particular header: + ;; "#~" + ;; length of version byte string (< 64) as one byte + ;; version byte string + ;; "B" + ;; 20 bytes of SHA-1 hash + (write-bytes '#vu8(35 126) port) + (let ([vers (string->bytes/utf-8 (version))]) + (write-bytes (bytes (bytes-length vers)) port) + (write-bytes vers port)) + (write-bytes '#vu8(66) port) + (write-bytes (make-bytes 20 0) port) + ;; The rest is whatever we want. We'll simply fasl the bundle. + (let-values ([(o get) (open-bytevector-output-port)]) + (fasl-write* b o) + (let ([bstr (get)]) + (write-int (bytes-length bstr) port) + (write-bytes bstr port)))) + +(define (linklet-bundle->bytes b) + (let ([o (open-output-bytes)]) + (write-linklet-bundle b o #t) + (get-output-bytes o))) + +(define (write-linklet-directory ld port mode) + ;; Various tools expect a particular header: + ;; "#~" + ;; length of version byte string (< 64) as one byte + ;; version byte string + ;; "D" + ;; bundle count as 4-byte integer + ;; binary tree: + ;; bundle-name length as 4-byte integer + ;; bundle name [encoding decribed below] + ;; bundle offset as 4-byte integer + ;; bundle size as 4-byte integer + ;; left-branch offset as 4-byte integer + ;; right-branch offset as 4-byte integer + ;; A bundle name corresponds to a list of symbols. Each symbol in the list is + ;; prefixed with either: its length as a byte if less than 255; 255 followed by + ;; a 4-byte integer for the length. + (write-bytes '#vu8(35 126) port) + (let ([vers (string->bytes/utf-8 (version))]) + (write-bytes (bytes (bytes-length vers)) port) + (write-bytes vers port) + (write-bytes '#vu8(68) port) + ;; Flatten a directory of bundles into a vector of pairs, where + ;; each pair has the encoded bundle name and the bundle bytes + (let* ([bundles (list->vector (flatten-linklet-directory ld '() '()))] + [len (vector-length bundles)] + [initial-offset (+ 2 ; "#~" + 1 ; version length + (bytes-length vers) + 1 ; D + 4)]) ; bundle count + (write-int len port) ; bundle count + (chez:vector-sort! (lambda (a b) (bytesbytes value)) + accum) + #t)] + [else + (loop (hash-iterate-next ht i) + (flatten-linklet-directory value (cons key rev-name-prefix) accum) + saw-bundle?)]))])))) + +;; Encode a bundle name (as a reversed list of symbols) as a single +;; byte string +(define (encode-name rev-name) + (define (encode-symbol s) + (let* ([bstr (string->bytes/utf-8 (symbol->string s))] + [len (bytes-length bstr)]) + (if (< len 255) + (list (bytes len) bstr) + (list (bytes 255) (integer->integer-bytes len 4 #f #f) bstr)))) + (let loop ([rev-name rev-name] [accum '()]) + (cond + [(null? rev-name) (apply bytes-append accum)] + [else + (loop (cdr rev-name) (append (encode-symbol (car rev-name)) + accum))]))) + +;; Figure out how big the binary tree will be, which depends +;; on the size of bundle-name byte strings +(define (compute-btree-size bundles len) + (let loop ([i 0] [size 0]) + (if (= i len) + size + (let ([nlen (bytes-length (car (vector-ref bundles i)))]) + ;; 5 numbers: name length, bundle offset, bundles size, lef, and right + (loop (fx1+ i) (+ size nlen (* 5 4))))))) + +;; Compute the offset where each node in the binary tree will reside +;; relative to the start of the bundle directory's "#~" +(define (compute-btree-node-offsets bundles len initial-offset) + (let ([node-offsets (make-vector len)]) + (let loop ([lo 0] [hi len] [offset initial-offset]) + (cond + [(= lo hi) offset] + [else + (let* ([mid (quotient (+ lo hi) 2)]) + (vector-set! node-offsets mid offset) + (let* ([nlen (bytes-length (car (vector-ref bundles mid)))] + [offset (+ offset 4 nlen 4 4 4 4)]) + (let ([offset (loop lo mid offset)]) + (loop (add1 mid) hi offset))))])) + node-offsets)) + +;; Compute the offset where each bundle will reside relative +;; to the start of the bundle directory's "#~" +(define (compute-bundle-offsets bundles len offset) + (let ([bundle-offsets (make-vector len)]) + (let loop ([i 0] [offset offset]) + (unless (= i len) + (vector-set! bundle-offsets i offset) + (loop (fx1+ i) (+ offset (bytes-length (cdr (vector-ref bundles i))))))) + bundle-offsets)) + +;; Write the binary tree for the directory: +(define (write-directory-btree bundles node-offsets bundle-offsets len port) + (let loop ([lo 0] [hi len]) + (cond + [(= lo hi) (void)] + [else + (let* ([mid (quotient (+ lo hi) 2)] + [p (vector-ref bundles mid)] + [nlen (bytes-length (car p))]) + (write-int nlen port) + (write-bytes (car p) port) + (write-int (vector-ref bundle-offsets mid) port) + (write-int (bytes-length (cdr p)) port) + (cond + [(> mid lo) + (let ([left (quotient (+ lo mid) 2)]) + (write-int (vector-ref node-offsets left) port))] + [else + (write-int 0 port)]) + (cond + [(< (fx1+ mid) hi) + (let ([right (quotient (+ (fx1+ mid) hi) 2)]) + (write-int (vector-ref node-offsets right) port))] + [else + (write-int 0 port)]) + (loop lo mid) + (loop (fx1+ mid) hi))]))) + +(define (write-int n port) + (write-bytes (integer->integer-bytes n 4 #f #f) port))