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))