cs: remove experimental JIT database support
Caching compiled JIT fragments in a SQLite database did not turn out to be a viable path, so remove partial support for it. JIT mode in general is rarely a good option, but it's at least completely worked out, so left in for now.
This commit is contained in:
Matthew Flatt
parent
2a7d94d89c
commit
28271158dd
|
|
@ -127,8 +127,7 @@ LINKLET_SRCS = linklet/version.ss \
|
|||
linklet/performance.ss \
|
||||
linklet/annotation.ss \
|
||||
linklet/compress.ss \
|
||||
linklet/cross-compile.ss \
|
||||
linklet/db.ss
|
||||
linklet/cross-compile.ss
|
||||
|
||||
$(BUILDDIR)linklet.$(CSO): linklet.sls $(LINKLET_SRCS) $(LINKLET_DEPS) $(COMPILE_FILE_DEPS)
|
||||
$(COMPILE_FILE) linklet.sls $(LINKLET_DEPS)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
The implementation of Racket on Chez Scheme in this directory is
|
||||
organized into two layers:
|
||||
The implementation of Racket on Chez Scheme (Racket CS) in this
|
||||
directory is organized into two layers:
|
||||
|
||||
* The immediate directory contains Scheme sources to implement Racket
|
||||
functionality on top of Chez Scheme. It references sibling
|
||||
|
|
@ -20,13 +20,13 @@ build).
|
|||
Requirements
|
||||
========================================================================
|
||||
|
||||
Building Racket-on-Chez requires both an existing Racket build and
|
||||
Chez Scheme build.
|
||||
Building Racket CS requires both an existing Racket build and Chez
|
||||
Scheme build.
|
||||
|
||||
The existing Racket must be "new enough" to build the current
|
||||
Racket-on-Chez version. In the worst case, it must be exactly the same
|
||||
version (using the traditional Racket implementation) as the one
|
||||
you're trying to build.
|
||||
The existing Racket must be "new enough" to build the current Racket
|
||||
CS version. In the worst case, it must be exactly the same version
|
||||
(using the traditional Racket implementation) as the one you're trying
|
||||
to build.
|
||||
|
||||
Note: When you use `configure --enable-cs` or similar as described
|
||||
in "../README.txt", then a bootstrapping variant of Racket is built
|
||||
|
|
@ -43,11 +43,11 @@ already), and see "Building Chez Scheme" below for building.
|
|||
Development versus Build
|
||||
========================================================================
|
||||
|
||||
The Racket-on-Chez implementation can be built and run in two
|
||||
different ways: development mode for running directly using a Chez
|
||||
Scheme installation, and build mode for creating a `racket` or
|
||||
`racketcs` executable that combines Chez Scheme and Racket
|
||||
functionality into a single executable.
|
||||
The Racket CS implementation can be built and run in two different
|
||||
ways: development mode for running directly using a Chez Scheme
|
||||
installation, and build mode for creating a `racket` or `racketcs`
|
||||
executable that combines Chez Scheme and Racket functionality into a
|
||||
single executable.
|
||||
|
||||
Development Mode
|
||||
----------------
|
||||
|
|
@ -80,11 +80,10 @@ makefile makes too many Unix-ish assumptions.
|
|||
Build Mode
|
||||
----------
|
||||
|
||||
To build a Racket-on-Chez executable, the `configure` script and
|
||||
makefile in "c" subdirectory are normally used via `configure` and
|
||||
`make` in the parent directory of this one, as described in
|
||||
"../README.txt". However, you can use them directly with something
|
||||
like
|
||||
To build a Racket CS executable, the `configure` script and makefile
|
||||
in "c" subdirectory are normally used via `configure` and `make` in
|
||||
the parent directory of this one, as described in "../README.txt".
|
||||
However, you can use them directly with something like
|
||||
|
||||
cd [build]
|
||||
mkdir cs
|
||||
|
|
@ -98,7 +97,7 @@ is a build directory (usually "../build" relative to [here]).
|
|||
|
||||
The `configure` script accepts flags like `--enable-racket=...` and
|
||||
`--enable-scheme=...` to select an existing Racket and a Chez Scheme
|
||||
build directory to use for building Racket-on-Chez:
|
||||
build directory to use for building Racket CS:
|
||||
|
||||
* By default, the build uses Racket as "[build]/racket/racket3m" and
|
||||
bootstraps bytecode from "[here]/../../collects".
|
||||
|
|
@ -109,12 +108,12 @@ build directory to use for building Racket-on-Chez:
|
|||
* By default, the build looks for a Chez Scheme build directory as
|
||||
"build/ChezScheme".
|
||||
|
||||
Building Racket-on-Chez requires a Chez Scheme build directory, not
|
||||
just a Chez Scheme installation that is accessible as `scheme`.
|
||||
Building Racket CS requires a Chez Scheme build directory, not just
|
||||
a Chez Scheme installation that is accessible as `scheme`.
|
||||
|
||||
The resulting Racket-on-Chez executable has the suffix "cs". To
|
||||
generate an executable without the "cs" suffix, supply
|
||||
`--enable-csdefault` to `configure`. The presence or absence of "cs"
|
||||
The resulting Racket CS executable has the suffix "cs". To generate an
|
||||
executable without the "cs" suffix, supply `--enable-csdefault` to
|
||||
`configure`. The option to select the presence or absence of "cs" also
|
||||
affects the location of ".zo" files.
|
||||
|
||||
Compilation on Windows does not use the `configure` script in "c".
|
||||
|
|
@ -129,7 +128,7 @@ not already present (in which case `git` must be available).
|
|||
Machine Code versus JIT
|
||||
========================================================================
|
||||
|
||||
Racket-on-Chez currently supports three compilation modes:
|
||||
Racket CS currently supports three compilation modes:
|
||||
|
||||
* Machine-code mode --- The compiled form of a module is machine code
|
||||
generated by compiling either whole linklets (for small enough
|
||||
|
|
@ -141,7 +140,7 @@ Racket-on-Chez currently supports three compilation modes:
|
|||
|
||||
In development mode or when the "cs" suffix is used for build mode,
|
||||
compiled ".zo" files in this mode are written to a subdirectory of
|
||||
"compiled" using the Chez Scheme platform name (e.g., "a6osx").
|
||||
"compiled" using the Chez Scheme platform name (e.g., "ta6osx").
|
||||
|
||||
Set `PLT_CS_COMPILE_LIMIT` to set the maximum size of forms to
|
||||
compile before falling back to interpreted "bytecode". The default
|
||||
|
|
@ -177,18 +176,11 @@ Racket-on-Chez currently supports three compilation modes:
|
|||
compiled ".zo" files in this mode are written to a "cs"
|
||||
subdirectory of "compiled".
|
||||
|
||||
S-expression 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.
|
||||
|
||||
In development mode or when the "cs" suffix is used for build mode,
|
||||
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
|
||||
which case setting `PLT_ZO_PATH` to something like "ta6osx-debug" could
|
||||
be a good idea.
|
||||
|
||||
|
||||
|
|
@ -228,7 +220,7 @@ Development mode is driven by the makefile in this directory.
|
|||
Building
|
||||
--------
|
||||
|
||||
Running `make` will build the Racket-on-Chez implementation. Use `make
|
||||
Running `make` will build the Racket CS implementation. Use `make
|
||||
expander-demo` to run a demo that loads `racket/base` from source.
|
||||
|
||||
Use `make setup` (or `make setup-v` for a verbose version) to build
|
||||
|
|
@ -251,8 +243,8 @@ running plain `racket`, where command-line arguments are supplied in
|
|||
Structure
|
||||
---------
|
||||
|
||||
The Racket-on-Chez implementation is in layers. The immediate layer
|
||||
over Chez Scheme is called "Rumble", and it implements delimited
|
||||
The Racket CS implementation is organized in layers. The immediate
|
||||
layer over Chez Scheme is called "Rumble", and it implements delimited
|
||||
continuations, structures, chaperones and impersonators, engines (for
|
||||
threads), and similar base functionality. The Rumble layer is
|
||||
implemented in Chez Scheme.
|
||||
|
|
@ -357,34 +349,7 @@ examples, including loading `racket/base` from source.
|
|||
Dumping Linklets and Schemified Linklets
|
||||
----------------------------------------
|
||||
|
||||
Set the `PLT_LINKLET_SHOW` environment variable to pretty print each
|
||||
linklet generated by the expander and its schemified form that is
|
||||
passed on to Chez Scheme.
|
||||
|
||||
By default, `PLT_LINKLET_SHOW` does not distinguish gensyms that have
|
||||
the same base name, so the schemified form is not really accurate. Set
|
||||
`PLT_LINKLET_SHOW_GENSYM` instead (or in addition) to get more
|
||||
accurate output.
|
||||
|
||||
In JIT mode, the schemified form is shown after a conversion to
|
||||
support JIT mode. Set `PLT_LINKLET_SHOW_PRE_JIT` to see the
|
||||
pre-conversion form. Set `PLT_LINKLET_SHOW_JIT_DEMAND` to see forms as
|
||||
they are compiled on demand.
|
||||
|
||||
In machine-code mode, set `PLT_LINKLET_SHOW_LAMBDA` to see individual
|
||||
compiled terms when a linklet is not compiled whole; set
|
||||
`PLT_LINKLET_SHOW_POST_LAMBDA` to see the linklet reorganized around
|
||||
those compiled parts; and/or set `PLT_LINKLET_SHOW_POST_INTERP` to see
|
||||
the "bytecode" form.
|
||||
|
||||
Set `PLT_LINKLET_SHOW_CP0` to see the Schemified form of a linklet
|
||||
after expansion and optimization by Chez Scheme's cp0.
|
||||
|
||||
Set `PLT_LINKLET_SHOW_ASSEMBLY` to see the assembly form of a linklet
|
||||
after compilation by Chez Scheme. Assembly format uses Chez Scheme's
|
||||
abstraction of architecture-specific machine instructions (where the
|
||||
assembly is translated to actual machine code in a fairly
|
||||
straightforward way).
|
||||
See "Inspecting Compiler Passes" in the Racket reference manual.
|
||||
|
||||
Safety and Debugging Mode
|
||||
-------------------------
|
||||
|
|
@ -395,13 +360,13 @@ If you make changes to files in "rumble", you should turn off
|
|||
You may want to turn on `DEBUG_COMP` in the makefile, so that
|
||||
backtraces provide expression-specific source locations instead of
|
||||
just procedure-specific source locations. Enabling `DEBUG_COMP` makes
|
||||
the Racket-on-Chez implementation take up twice as much memory and
|
||||
take twice as long to load.
|
||||
the Racket CS implementation take up twice as much memory and take
|
||||
twice as long to load.
|
||||
|
||||
Turning on `DEBUG_COMP` affects only the Racket-on-Chez
|
||||
implementation. To preserve per-expression locations on compiled
|
||||
Racket code, set `PLT_CS_DEBUG`. See also "JIT versus Machine Code"
|
||||
for a suggestion on setting `PLT_ZO_PATH`.
|
||||
Turning on `DEBUG_COMP` affects only the Racket CS implementation. To
|
||||
preserve per-expression locations on compiled Racket code, set
|
||||
`PLT_CS_DEBUG`. See also "JIT versus Machine Code" for a suggestion on
|
||||
setting `PLT_ZO_PATH`.
|
||||
|
||||
When you change "rumble" or other layers, you can continue to use
|
||||
Racket modules that were previously compiled to ".zo" form... usually,
|
||||
|
|
@ -411,8 +376,8 @@ compatibility.
|
|||
FFI Differences
|
||||
---------------
|
||||
|
||||
Compared to the traditional Racket implementation, Racket-on-Chez's
|
||||
FFI behaves in several different ways:
|
||||
Compared to the traditional Racket implementation, Racket CS's FFI
|
||||
behaves in several different ways:
|
||||
|
||||
* The `make-sized-byte-string` function always raises an exception,
|
||||
because a foreign address cannot be turned into a byte string whose
|
||||
|
|
@ -425,10 +390,6 @@ FFI behaves in several different ways:
|
|||
is used as a result type, the C result is copied into a fresh byte
|
||||
string.
|
||||
|
||||
* The 'atomic-interior allocation mode returns memory that is allowed
|
||||
to move after the cpointer returned by allocation becomes
|
||||
unreachable.
|
||||
|
||||
* A `_gcpointer` can only refer to the start of an allocated object,
|
||||
and never the interior of an 'atomic-interior allocation. Like
|
||||
traditional Racket, `_gcpointer` is equivalent to `_pointer` for
|
||||
|
|
@ -440,7 +401,9 @@ FFI behaves in several different ways:
|
|||
|
||||
* Calling a foreign function implicitly uses atomic mode and also
|
||||
disables GC. If the foreign function calls back to Racket, the
|
||||
callback runs in atomic mode with the GC still disabled.
|
||||
callback runs in atomic mode with the GC still disabled. Use the
|
||||
`blocking?` option for a foreign call or callback to adjuse that
|
||||
behavior.
|
||||
|
||||
* An immobile cell must be modified only through its original pointer
|
||||
or a reconstructed `_gcpointer`. If it is cast or reconstructed as
|
||||
|
|
@ -534,7 +497,7 @@ configuration:
|
|||
other layers by 30-50%.
|
||||
|
||||
* `PLT_CS_DEBUG` not set --- an environment variable similar to
|
||||
`DEBUG_COMP`, but applies to code compiled by Racket-on-Chez.
|
||||
`DEBUG_COMP`, but applies to code compiled by Racket CS.
|
||||
|
||||
Effectiveness: Avoids improvement to stack traces, but also avoids
|
||||
increases load time and memory use of Racket programs by as much as
|
||||
|
|
|
|||
|
|
@ -137,17 +137,6 @@
|
|||
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? (not (eq? linklet-compilation-mode 'mach)))
|
||||
|
||||
|
|
@ -225,7 +214,6 @@
|
|||
(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
|
||||
|
|
@ -353,28 +341,6 @@
|
|||
(fx= (char->integer #\e) (bytevector-u8-ref bv 6))
|
||||
(fx= (char->integer #\z) (bytevector-u8-ref bv 7))))
|
||||
|
||||
(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 or (vector hash annotation) for 'jit mode
|
||||
arity-mask
|
||||
|
|
@ -387,38 +353,17 @@
|
|||
f
|
||||
(performance-region
|
||||
'on-demand
|
||||
(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 (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)]))))))
|
||||
(cond
|
||||
[(bytevector? f)
|
||||
(let* ([f (code-from-bytevector f)])
|
||||
(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)])
|
||||
|
|
@ -612,9 +557,7 @@
|
|||
;; Preserve annotated `lambda` source for on-demand compilation:
|
||||
(lambda (expr arity-mask name)
|
||||
(let ([a (correlated->annotation (xify expr) serializable? sfd-cache)])
|
||||
(make-wrapped-code (if serializable?
|
||||
(add-code-hash a)
|
||||
a)
|
||||
(make-wrapped-code a
|
||||
arity-mask
|
||||
(extract-inferred-name expr name))))]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -1,266 +0,0 @@
|
|||
|
||||
;; 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))))))
|
||||
Loading…
Reference in New Issue
Block a user