suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: interpret short-lived compile-time code

Browse Source 
Instead of compiling the right-hand side of a `let-syntax`, interpret
using the schemify layer's safe-for-space interpreter. Similarly,
interpret the right-hand side of `define-syntax` when it is evaluated
during the enclosing module's expansion (compiling it for use when the
enclosing module is instantiated for expanding other modules).

This is an old idea, and it's effective in some cases: `racketcs -cl
racket/base` or `racketcs -cl racket` takes 20% less time with this
change. Various obstacles kept us from trying this earlier; most
significantly, the gap to finish the safe-for-space interpreter was
small enough to make it work. It's not clear that the result is an
improvement for `raco setup`, though.

The interpreter is not fast (it's about 1/4 the speed of the
traditional Racket interpreter), so there's room for improvement,
but even a slow interpreter pays off for building.
This commit is contained in:
Matthew Flatt 2019-12-21 06:44:36 -07:00
parent 53d7387f6c
commit c8c3647da5
19 changed files with 827 additions and 407 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
pkgs/racket-doc/scribblings/reference/linklet.scrbl
View File

@ -120,7 +120,7 @@ otherwise.}
[name any/c #f]
[import-keys #f #f]
[get-import #f #f]
[options (listof (or/c 'serializable 'unsafe 'static
[options (listof (or/c 'serializable 'unsafe 'static 'quick
'use-prompt 'uninterned-literal))
'(serializable)])
linklet?]
@ -130,7 +130,7 @@ otherwise.}
[get-import (or/c #f (any/c . -> . (values (or/c linklet? instance? #f)
(or/c vector? #f))))
#f]
[options (listof (or/c 'serializable 'unsafe 'static
[options (listof (or/c 'serializable 'unsafe 'static 'quick
'use-prompt 'uninterned-literal))
'(serializable)])
(values linklet? vector?)])]{
@ -194,6 +194,11 @@ at most once. Compilation with @racket['static] is intended to improve
the performance of references within the linklet to defined and
imported variables.
If @racket['quick] is included in @racket[options], then linklet
compilation may trade run-time performance for compile-time
performance---that is, spend less time compiling the linklet, but the
resulting linklet may run more slowly.
If @racket['use-prompt] is included in @racket[options], then
instantiating resulting linklet always wraps a prompt around each
definition and immediate expression in the linklet. Otherwise,
@ -212,14 +217,15 @@ The symbols in @racket[options] must be distinct, otherwise
@exnraise[exn:fail:contract].
@history[#:changed "7.1.0.8" @elem{Added the @racket['use-prompt] option.}
#:changed "7.1.0.10" @elem{Added the @racket['uninterned-literal] option.}]}
#:changed "7.1.0.10" @elem{Added the @racket['uninterned-literal] option.}
#:changed "7.5.0.14" @elem{Added the @racket['quick] option.}]}
@defproc*[([(recompile-linklet [linklet linklet?]
[name any/c #f]
[import-keys #f #f]
[get-import #f #f]
[options (listof (or/c 'serializable 'unsafe 'static
[options (listof (or/c 'serializable 'unsafe 'static 'quick
'use-prompt 'uninterned-literal))
'(serializable)])
linklet?]
@ -230,7 +236,7 @@ The symbols in @racket[options] must be distinct, otherwise
(or/c vector? #f)))
#f)
(lambda (import-key) (values #f #f))]
[options (listof (or/c 'serializable 'unsafe 'static
[options (listof (or/c 'serializable 'unsafe 'static 'quick
'use-prompt 'uninterned-literal))
'(serializable)])
(values linklet? vector?)])]{
@ -240,7 +246,8 @@ and potentially optimizes it further.
@history[#:changed "7.1.0.6" @elem{Added the @racket[options] argument.}
#:changed "7.1.0.8" @elem{Added the @racket['use-prompt] option.}
#:changed "7.1.0.10" @elem{Added the @racket['uninterned-literal] option.}]}
#:changed "7.1.0.10" @elem{Added the @racket['uninterned-literal] option.}
#:changed "7.5.0.14" @elem{Added the @racket['quick] option.}]}
@defproc[(eval-linklet [linklet linklet?]) linklet?]{

2
pkgs/racket-test-core/tests/racket/procs.rktl
View File

@ -508,7 +508,7 @@
(set! f #f))
;; ----------------------------------------
;; Check mutation of direct-called keyword procedure
;; Check name of keyword procedure
(let ()
(define (f1 #:x x) (list x))

22
pkgs/racket-test-core/tests/racket/unsafe.rktl
View File

@ -928,12 +928,22 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that constant folding doesn't go wrong for `unsafe-fxlshift`:
(test #t fixnum? (if (eqv? 64 (system-type 'word))
(unsafe-fxlshift 1 62)
(unsafe-fxlshift 1 30)))
(test #t zero? (if (eqv? 64 (system-type 'word))
(unsafe-fxlshift 1 63)
(unsafe-fxlshift 1 31)))
(test #t procedure? (lambda ()
(if (eqv? 64 (system-type 'word))
(unsafe-fxlshift 1 60)
(unsafe-fxlshift 1 28))))
(test #t procedure? (lambda ()
(if (eqv? 64 (system-type 'word))
(unsafe-fxlshift 1 61)
(unsafe-fxlshift 1 29))))
(test #t procedure? (lambda ()
(if (eqv? 64 (system-type 'word))
(unsafe-fxlshift 1 62)
(unsafe-fxlshift 1 30))))
(test #t procedure? (lambda ()
(if (eqv? 64 (system-type 'word))
(unsafe-fxlshift 1 63)
(unsafe-fxlshift 1 31))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that allocation by inlined `unsafe-flrandom` is ok

24
racket/src/cs/README.txt
View File

@ -129,7 +129,7 @@ not already present (in which case `git` must be available).
Machine Code versus JIT
========================================================================
Racket-on-Chez currently supports two compilation modes:
Racket-on-Chez 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
@ -148,6 +148,26 @@ Racket-on-Chez currently supports two compilation modes:
is 10000. Setting `PLT_CS_COMPILE_LIMIT` to 0 effectively turns
the implementation into a pure interpreter.
* Interpreter mode --- The compiled form of a module is a "bytecode"
tree (not unlike the traditional Racket's bytecode) that is
interpreted.
Select this mode by setting the `PLT_CS_INTERP` environment
variable. Alternatively, set `PLT_LINKLET_COMPILE_QUICK` when
otherwise using machine-code mode (where the difference has to do
with where compiled file are read and written in development mode).
At the linklet API level, this mode implements the 'quick option to
`compile-linklet` and similar functions.
In development mode or when the "cs" suffix is used for build mode,
compiled ".zo" files in this mode are written to a "cs"
subdirectory of "compiled".
Interpreter mode is used automatically for large modules in
machine-code mode, as controlled by `PLT_CS_COMPILE_LIMIT`. It is
also used by default for compile-time code within a module while
that same module is being expanded.
* JIT mode --- The compiled form of a module is an S-expression where
individual `lambda`s are compiled on demand.
@ -157,7 +177,7 @@ Racket-on-Chez currently supports two compilation modes:
compiled ".zo" files in this mode are written to a "cs"
subdirectory of "compiled".
S-expressions fragments are hashed at compilation time, so that the
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`

54
racket/src/cs/linklet.sls
View File

@ -120,6 +120,7 @@
(cond
[(getenv "PLT_CS_JIT") 'jit]
[(getenv "PLT_CS_MACH") 'mach]
[(getenv "PLT_CS_INTERP") 'interp]
[else 'mach]))
(define linklet-compilation-limit
@ -143,7 +144,7 @@
[else (bytes->path bstr)])))
;; For "main.sps" to select the default ".zo" directory name:
(define platform-independent-zo-mode? (eq? linklet-compilation-mode 'jit))
(define platform-independent-zo-mode? (not (eq? linklet-compilation-mode 'mach)))
(define (primitive->compiled-position prim) #f)
(define (compiled-position->primitive pos) #f)
@ -154,6 +155,11 @@
(define omit-debugging? (not (getenv "PLT_CS_DEBUG")))
(define measure-performance? (getenv "PLT_LINKLET_TIMES"))
;; The difference between this and `PLT_CS_INTERP` is that
;; this one keeps using existing compiled code in a machine-specific
;; "compiled" directory:
(define default-compile-quick? (getenv "PLT_LINKLET_COMPILE_QUICK"))
(define compress-code? (cond
[(getenv "PLT_LINKLET_COMPRESS") #t]
[(getenv "PLT_LINKLET_NO_COMPRESS") #f]
@ -223,7 +229,7 @@
(compile e))
(compile e)))))]
[(e) (compile* e #t)]))
(define (interpret* e)
(define (interpret* e) ; result is not safe for space
(call-with-system-wind (lambda () (interpret e))))
(define (fasl-write* s o)
(call-with-system-wind (lambda () (fasl-write s o))))
@ -249,11 +255,13 @@
;; prropagate table to the rumble layer
(install-primitives-table! primitives))
(define (outer-eval s paths format)
;; Runs the result of `interpretable-jitified-linklet`
(define (run-interpret s paths)
(interpret-linklet s paths))
(define (compile-to-proc s paths format)
(if (eq? format 'interpret)
(interpret-linklet s paths primitives variable-ref variable-ref/no-check
variable-set! variable-set!/define
make-arity-wrapper-procedure)
(run-interpret s paths)
(let ([proc (compile* s)])
(if (null? paths)
proc
@ -300,7 +308,7 @@
(fasl-read (open-bytevector-input-port bv)))])
(performance-region
'outer
(outer-eval r paths format)))]
(run-interpret r paths)))]
[else
(let ([proc (performance-region
'faslin-code
@ -524,20 +532,28 @@
m))))
(define enforce-constant? (|#%app| compile-enforce-module-constants))
(define inline? (not (|#%app| compile-context-preservation-enabled)))
(define quick-mode? (or default-compile-quick?
(and (not serializable?)
(#%memq 'quick options))))
(performance-region
'schemify
(define jitify-mode?
(or (eq? linklet-compilation-mode 'jit)
(and (linklet-bigger-than? c linklet-compilation-limit serializable?)
(and (eq? linklet-compilation-mode 'mach)
(linklet-bigger-than? c linklet-compilation-limit serializable?)
(log-message root-logger 'info 'linklet "compiling only interior functions for large linklet" #f)
#t)))
(define format (if jitify-mode? 'interpret 'compile))
(define format (if (or jitify-mode?
quick-mode?
(eq? linklet-compilation-mode 'interp))
'interpret
'compile))
;; Convert the linklet S-expression to a `lambda` S-expression:
(define-values (impl-lam importss exports new-import-keys importss-abi exports-info)
(schemify-linklet (show "linklet" c)
serializable?
(not (#%memq 'uninterned-literal options))
jitify-mode?
(eq? format 'interpret)
(|#%app| compile-allow-set!-undefined)
#f ;; safe mode
enforce-constant?
@ -596,19 +612,19 @@
code))))])))]))
(define-values (paths impl-lam/paths)
(if serializable?
(extract-paths-and-fasls-from-schemified-linklet impl-lam/jitified (not jitify-mode?))
(extract-paths-and-fasls-from-schemified-linklet impl-lam/jitified (eq? format 'compile))
(values '() impl-lam/jitified)))
(define impl-lam/interpable
(let ([impl-lam (case (and jitify-mode?
linklet-compilation-mode)
[(mach) (show post-lambda-on? "post-lambda" impl-lam/paths)]
[else (show "schemified" impl-lam/paths)])])
(if jitify-mode?
(interpretable-jitified-linklet impl-lam correlated->datum)
(if (eq? format 'interpret)
(interpretable-jitified-linklet impl-lam serializable?)
(correlated->annotation impl-lam serializable?))))
(when known-on?
(show "known" (hash-map exports-info (lambda (k v) (list k v)))))
(when (and cp0-on? (not jitify-mode?))
(when (and cp0-on? (eq? format 'compile))
(show "cp0" (#%expand/optimize (correlated->annotation impl-lam/paths))))
(performance-region
'compile-linklet
@ -617,8 +633,8 @@
(if cross-machine
(make-cross-compile-to-bytevector cross-machine)
compile-to-bytevector)
outer-eval)
(show (and jitify-mode? post-interp-on?) "post-interp" impl-lam/interpable)
compile-to-proc)
(show (and (eq? format 'interpret) post-interp-on?) "post-interp" impl-lam/interpable)
paths
format)
paths
@ -1204,6 +1220,12 @@
;; --------------------------------------------------
(interpreter-link! primitives
correlated->datum
variable-ref variable-ref/no-check
variable-set! variable-set!/define
make-interp-procedure)
(when omit-debugging?
(generate-inspector-information (not omit-debugging?))
(generate-procedure-source-information #t))

4
racket/src/cs/linklet/check.ss
View File

@ -35,8 +35,10 @@
(loop (cdr options) (or redundant use-prompt) serializable unsafe static 'use-prompt uninterned-literal)]
[(uninterned-literal)
(loop (cdr options) (or redundant uninterned-literal) serializable unsafe static use-prompt 'uninterned-literal)]
[(quick)
(loop (cdr options) redundant serializable unsafe static use-prompt uninterned-literal)]
[else
(loop #f redundant serializable unsafe static use-prompt uninterned-literal)])]
[else
(raise-argument-error who "(listof/c 'serializable 'unsafe 'static 'use-prompt 'uninterned-literal)"
(raise-argument-error who "(listof/c 'serializable 'unsafe 'static 'quick 'use-prompt 'uninterned-literal)"
orig-options)])))

7
racket/src/cs/rumble.sls
View File

@ -160,9 +160,10 @@
primitive?
primitive-closure?
primitive-result-arity
make-jit-procedure ; not exported to racket
|#%name| ; not exported to racket
|#%method-arity| ; not exported to racket
make-jit-procedure ; not exported to racket
make-interp-procedure ; not exported to racket
|#%name| ; not exported to racket
|#%method-arity| ; not exported to racket
equal?
equal?/recur

9
racket/src/cs/rumble/procedure.ss
View File

@ -523,6 +523,15 @@
name)])
p))
;; A boxed `name` means a method
(define (make-interp-procedure proc mask name)
(make-arity-wrapper-procedure
proc
mask
(if (box? name)
(vector (unbox name) proc 'method)
(vector name proc))))
(define (extract-wrapper-procedure-name p)
(let ([name (wrapper-procedure-data p)])
(cond

1
racket/src/cs/schemify.sls
View File

@ -4,6 +4,7 @@
jitify-schemified-linklet
xify
extract-paths-and-fasls-from-schemified-linklet
interpreter-link!
interpretable-jitified-linklet
interpret-linklet
linklet-bigger-than?

20
racket/src/expander/compile/form.rkt
View File

@ -48,7 +48,7 @@
#:serializable? [serializable? #t]
#:module-prompt? [module-prompt? #f]
#:to-correlated-linklet? [to-correlated-linklet? #f]
#:cross-linklet-inlining? [cross-linklet-inlining? #t])
#:optimize-linklet? [optimize-linklet? #t])
(define phase (compile-context-phase cctx))
(define self (compile-context-self cctx))
@ -236,7 +236,7 @@
(for/hash ([phase (in-list phases-in-order)])
(define header (hash-ref phase-to-header phase #f))
(define-values (link-module-uses imports extra-inspectorsss def-decls)
(generate-links+imports header phase cctx cross-linklet-inlining?))
(generate-links+imports header phase cctx optimize-linklet?))
(values phase (link-info link-module-uses imports extra-inspectorsss def-decls))))
;; Generate the phase-specific linking units
@ -279,7 +279,7 @@
#:serializable? serializable?
#:module-prompt? module-prompt?
#:module-use*s module-use*s
#:cross-linklet-inlining? cross-linklet-inlining?
#:optimize-linklet? optimize-linklet?
#:load-modules? #f
#:namespace (compile-context-namespace cctx))]))
(values phase (cons linklet new-module-use*s))))
@ -300,7 +300,7 @@
[(extra-inspectorsss) (in-value (module-uses-extract-extra-inspectorsss
(cdr l+mu*s)
(car l+mu*s)
(and cross-linklet-inlining?
(and optimize-linklet?
(not to-correlated-linklet?))
(length body-imports)))]
#:when extra-inspectorsss)
@ -396,7 +396,7 @@
#:serializable? serializable?
#:module-prompt? module-prompt?
#:module-use*s module-use*s
#:cross-linklet-inlining? cross-linklet-inlining?
#:optimize-linklet? optimize-linklet?
#:load-modules? load-modules?
#:namespace namespace)
(define-values (linklet new-module-use*s)
@ -409,7 +409,9 @@
'(serializable))
(if module-prompt?
'(use-prompt)
'()))))
(if optimize-linklet?
'()
'(quick))))))
body-linklet
'module
;; Support for cross-module optimization starts with a vector
@ -421,7 +423,7 @@
;; To complete cross-module support, map a key (which is a `module-use`)
;; to a linklet and an optional vector of keys for that linklet's
;; imports:
(make-module-use-to-linklet cross-linklet-inlining?
(make-module-use-to-linklet optimize-linklet?
load-modules?
namespace
get-module-linklet-info
@ -431,7 +433,7 @@
;; ----------------------------------------
(define (make-module-use-to-linklet cross-linklet-inlining? load-modules?
(define (make-module-use-to-linklet optimize-linklet? load-modules?
ns get-module-linklet-info init-mu*s)
;; Inlining might reach the same module though different indirections;
;; use a consistent `module-use` value so that the compiler knows to
@ -458,7 +460,7 @@
;; that would change the overall protocol for module or
;; top-level linklets), but it can describe shapes.
(values mu*-or-instance #f)]
[(not cross-linklet-inlining?)
[(not optimize-linklet?)
;; Although we let instances through, because that's cheap,
;; don't track down linklets and allow inlining of functions
(values #f #f)]

2
racket/src/expander/compile/recompile.rkt
View File

@ -188,7 +188,7 @@
#:serializable? #t
#:module-prompt? #t
#:module-use*s module-use*s
#:cross-linklet-inlining? #t
#:optimize-linklet? #t
#:load-modules? #t
#:namespace ns))
(values phase (cons linklet new-module-use*s))))

2
racket/src/expander/compile/top.rkt
View File

@ -83,7 +83,7 @@
#:other-form-callback (lambda (s cctx)
(set! purely-functional? #f)
(compile-top-level-require s cctx))
#:cross-linklet-inlining? (not single-expression?)))
#:optimize-linklet? (not single-expression?)))
(define (add-metadata ht)
(let* ([ht (hash-set ht 'original-phase phase)]

10
racket/src/racket/src/linklet.c
View File

@ -15,6 +15,7 @@ static Scheme_Object *unsafe_symbol;
static Scheme_Object *static_symbol;
static Scheme_Object *use_prompt_symbol;
static Scheme_Object *uninterned_literal_symbol;
static Scheme_Object *quick_symbol;
static Scheme_Object *constant_symbol;
static Scheme_Object *consistent_symbol;
static Scheme_Object *noncm_symbol;
@ -102,11 +103,13 @@ void scheme_init_linklet(Scheme_Startup_Env *env)
REGISTER_SO(static_symbol);
REGISTER_SO(use_prompt_symbol);
REGISTER_SO(uninterned_literal_symbol);
REGISTER_SO(quick_symbol);
serializable_symbol = scheme_intern_symbol("serializable");
unsafe_symbol = scheme_intern_symbol("unsafe");
static_symbol = scheme_intern_symbol("static");
use_prompt_symbol = scheme_intern_symbol("use-prompt");
uninterned_literal_symbol = scheme_intern_symbol("uninterned-literal");
quick_symbol = scheme_intern_symbol("quick");
REGISTER_SO(constant_symbol);
REGISTER_SO(consistent_symbol);
@ -364,6 +367,7 @@ static void parse_compile_options(const char *who, int arg_pos,
int static_mode = *_static_mode;
int use_prompt_mode = 0;
int uninterned_literal_mode = 0;
int quick_mode = 0;
while (SCHEME_PAIRP(flags)) {
flag = SCHEME_CAR(flags);
@ -387,6 +391,10 @@ static void parse_compile_options(const char *who, int arg_pos,
if (uninterned_literal_mode && !redundant)
redundant = flag;
uninterned_literal_mode = 1;
} else if (SAME_OBJ(flag, quick_symbol)) {
if (quick_mode && !redundant)
redundant = flag;
quick_mode = 1;
} else
break;
flags = SCHEME_CDR(flags);
@ -394,7 +402,7 @@ static void parse_compile_options(const char *who, int arg_pos,
if (!SCHEME_NULLP(flags))
scheme_wrong_contract("compile-linklet",
"(listof/c 'serializable 'unsafe 'static 'use-prompt 'uninterned-literal)",
"(listof/c 'serializable 'unsafe 'static 'use-prompt 'uninterned-literal 'quick)",
arg_pos, argc, argv);
if (redundant)

34
racket/src/racket/src/startup.inc
View File

@ -32007,12 +32007,12 @@ static const char *startup_source =
" body-imports2_0"
" body-suffix-forms4_0"
" compiled-expression-callback8_0"
" cross-linklet-inlining?15_0"
" definition-callback9_0"
" encoded-root-expand-ctx-box6_0"
" force-phases5_0"
" get-module-linklet-info11_0"
" module-prompt?13_0"
" optimize-linklet?15_0"
" other-form-callback10_0"
" root-ctx-only-if-syntax?7_0"
" serializable?12_0"
@ -32048,7 +32048,7 @@ static const char *startup_source =
"(let-values(((serializable?_0) serializable?12_0))"
"(let-values(((module-prompt?_0) module-prompt?13_0))"
"(let-values(((to-correlated-linklet?_0) to-correlated-linklet?14_0))"
"(let-values(((cross-linklet-inlining?_0) cross-linklet-inlining?15_0))"
"(let-values(((optimize-linklet?_0) optimize-linklet?15_0))"
"(let-values()"
"(let-values(((phase_0)(compile-context-phase cctx_0)))"
"(let-values(((self_0)(compile-context-self cctx_0)))"
@ -33059,7 +33059,7 @@ static const char *startup_source =
" header_0"
" phase_1"
" cctx_0"
" cross-linklet-inlining?_0)))"
" optimize-linklet?_0)))"
"(values"
" phase_1"
"(link-info1.1"
@ -33228,8 +33228,8 @@ static const char *startup_source =
" module-prompt?_0)"
"((module-use*s83_0)"
" module-use*s_0)"
"((cross-linklet-inlining?84_0)"
" cross-linklet-inlining?_0)"
"((optimize-linklet?84_0)"
" optimize-linklet?_0)"
"((temp85_0)"
" #f)"
"((temp86_0)"
@ -33239,12 +33239,12 @@ static const char *startup_source =
" body-import-instances79_0"
" body-imports78_0"
" unsafe-undefined"
" cross-linklet-inlining?84_0"
" get-module-linklet-info80_0"
" temp85_0"
" module-prompt?82_0"
" module-use*s83_0"
" temp86_0"
" optimize-linklet?84_0"
" serializable?81_0"
" body-linklet77_0))))))"
"(values"
@ -33405,7 +33405,7 @@ static const char *startup_source =
" l+mu*s_0)"
"(car"
" l+mu*s_0)"
"(if cross-linklet-inlining?_0"
"(if optimize-linklet?_0"
"(not"
" to-correlated-linklet?_0)"
" #f)"
@ -33624,12 +33624,12 @@ static const char *startup_source =
"(lambda(body-import-instances36_0"
" body-imports35_0"
" compile-linklet34_0"
" cross-linklet-inlining?41_0"
" get-module-linklet-info37_0"
" load-modules?42_0"
" module-prompt?39_0"
" module-use*s40_0"
" namespace43_0"
" optimize-linklet?41_0"
" serializable?38_0"
" body-linklet54_0)"
"(begin"
@ -33643,7 +33643,7 @@ static const char *startup_source =
"(let-values(((serializable?_0) serializable?38_0))"
"(let-values(((module-prompt?_0) module-prompt?39_0))"
"(let-values(((module-use*s_0) module-use*s40_0))"
"(let-values(((cross-linklet-inlining?_0) cross-linklet-inlining?41_0))"
"(let-values(((optimize-linklet?_0) optimize-linklet?41_0))"
"(let-values(((load-modules?_0) load-modules?42_0))"
"(let-values(((namespace_0) namespace43_0))"
"(let-values()"
@ -33662,12 +33662,14 @@ static const char *startup_source =
" getter_0"
"(if serializable?_0"
"(if module-prompt?_0 '(serializable use-prompt) '(serializable))"
"(if module-prompt?_0 '(use-prompt) '()))))"
"(if module-prompt?_0"
" '(use-prompt)"
"(if optimize-linklet?_0 '() '(quick))))))"
" body-linklet_0"
" 'module"
"(list->vector(append body-import-instances_0 module-use*s_0))"
"(make-module-use-to-linklet"
" cross-linklet-inlining?_0"
" optimize-linklet?_0"
" load-modules?_0"
" namespace_0"
" get-module-linklet-info_0"
@ -33680,7 +33682,7 @@ static const char *startup_source =
"(list-tail(vector->list new-module-use*s_0)(length body-imports_0)))))))))))))))))))"
"(define-values"
"(make-module-use-to-linklet)"
"(lambda(cross-linklet-inlining?_0 load-modules?_0 ns_0 get-module-linklet-info_0 init-mu*s_0)"
"(lambda(optimize-linklet?_0 load-modules?_0 ns_0 get-module-linklet-info_0 init-mu*s_0)"
"(begin"
"(let-values(((mu*-intern-table_0)(make-hash)))"
"(let-values(((intern-module-use*_0)"
@ -33723,7 +33725,7 @@ static const char *startup_source =
"(lambda(mu*-or-instance_0)"
"(if(1/instance? mu*-or-instance_0)"
"(let-values()(values mu*-or-instance_0 #f))"
"(if(not cross-linklet-inlining?_0)"
"(if(not optimize-linklet?_0)"
"(let-values()(values #f #f))"
"(if mu*-or-instance_0"
"(let-values()"
@ -37063,12 +37065,12 @@ static const char *startup_source =
" temp17_0"
" null"
" temp22_0"
" temp24_0"
" temp21_0"
" #f"
" null"
" unsafe-undefined"
" #f"
" temp24_0"
" temp23_0"
" #f"
" serializable?19_0"
@ -40070,12 +40072,12 @@ static const char *startup_source =
" temp60_0"
" temp62_0"
" check-side-effects!66_0"
" #t"
" unsafe-undefined"
" encoded-root-expand-ctx-box64_0"
" temp63_0"
" temp68_0"
" temp70_0"
" #t"
" temp67_0"
" body-context-simple?65_0"
" serializable?69_0"
@ -41129,12 +41131,12 @@ static const char *startup_source =
" temp6_0"
" temp5_0"
" temp4_0"
" temp11_0"
" find-submodule7_0"
" temp12_0"
" temp9_0"
" module-use*s10_0"
" ns13_0"
" temp11_0"
" temp8_0"
" temp3_0))))"
"(values"

38
racket/src/schemify/interp-stack.rkt
View File

@ -10,9 +10,11 @@
stack-remove
push-stack
(struct-out stack-info)
make-stack-info
stack-info-local-use-map
stack->pos
stack-info-branch
stack-info-branch-need-clears?
stack-info-merge!
stack-info-forget!
stack-info-non-tail!)
@ -72,7 +74,17 @@
closure-map ; hash table to collect variables byond boundary to capture
[use-map #:mutable] ; table of uses; an entry here means the binding is used later
[local-use-map #:mutable] ; subset of `use-map` used to tracked needed merging for branches
[non-tail-at-depth #:mutable])) ; stack depth at non-tail call (that needs space safety)
[non-tail-call-later? #:mutable])) ; non-tail call afterward?
(define (make-stack-info #:capture-depth [capture-depth #f]
#:closure-map [closure-map #hasheq()]
#:track-use? [track-use? #f])
(stack-info capture-depth
closure-map
(and track-use? #hasheq())
#f
#f))
;; Map a compile-time environment coordinate `i` to a run-time access
;; index. If this this access is the last one --- which is the first
@ -113,8 +125,8 @@
(set-stack-info-local-use-map! stk-i (hash-set local-use-map pos #t)))
;; We only need to remove from the environment if there's a
;; non-tail call later where the binding would be retained
;; across the call
(if (i . < . (stack-info-non-tail-at-depth stk-i))
;; across the call.
(if (stack-info-non-tail-call-later? stk-i)
(box pos)
pos)])]))
@ -124,7 +136,10 @@
(stack-info-closure-map stk-i)
(stack-info-use-map stk-i)
#hasheq()
(stack-info-non-tail-at-depth stk-i)))
(stack-info-non-tail-call-later? stk-i)))
(define (stack-info-branch-need-clears? stk-i)
(stack-info-non-tail-call-later? stk-i))
;; Merge branches back together, returning the set of all bindings
;; that has last uses across all branches. The returned information
@ -141,17 +156,14 @@
(define local-use-map (stack-info-local-use-map stk-i))
(when local-use-map
(set-stack-info-local-use-map! stk-i (hash-set local-use-map pos #t)))
(set-stack-info-non-tail-at-depth! stk-i
(max (stack-info-non-tail-at-depth stk-i)
(stack-info-non-tail-at-depth branch-stk-i)))))
(set-stack-info-non-tail-call-later?! stk-i
(or (stack-info-non-tail-call-later? stk-i)
(stack-info-non-tail-call-later? branch-stk-i)))))
all-clear)
;; Indicate that some bindings are "popped" from the stack, which
;; means that they no longer count as used, etc.
(define (stack-info-forget! stk-i stack-depth start-pos len)
(set-stack-info-non-tail-at-depth! stk-i
(min (stack-info-non-tail-at-depth stk-i)
stack-depth))
(when (stack-info-use-map stk-i)
(for ([i (in-range len)])
(define pos (+ start-pos i))
@ -163,6 +175,4 @@
;; Record the current stack depth at a non-tail call.
(define (stack-info-non-tail! stk-i stack-depth)
(set-stack-info-non-tail-at-depth! stk-i
(max (stack-info-non-tail-at-depth stk-i)
stack-depth)))
(set-stack-info-non-tail-call-later?! stk-i #t))

619
racket/src/schemify/interpret.rkt
View File

File diff suppressed because it is too large Load Diff

342
racket/src/schemify/intmap.rkt
View File

@ -2,133 +2,253 @@
(require racket/fixnum
(for-syntax racket/base))
;; Simplified version of Jon Zeppieri's intmap
;; implementation for Racket-on-Chez.
;; This one always has fixnum keys, doesn't have
;; to hash, doesn't have to deal with collisions,
;; and doesn't need a wrapper to distinguish
;; the type and record the comparison function.
(provide empty-intmap
intmap-count
intmap-count ; not constant-time
intmap-ref
intmap-set
intmap-remove)
(define empty-intmap #f)
;; AVL tree where keys are always fixnums
(struct Br (count prefix mask left right) #:transparent)
;; ----------------------------------------
(struct Lf (key value) #:transparent)
(struct node (key val height left right)
#:transparent
#:authentic)
(define (intmap-count t)
;; ----------------------------------------
(define (tree-height t)
(cond
[(not t) 0]
[else (node-height t)]))
(define (combine key val left right)
(node key
val
(fx+ 1 (fxmax (tree-height left) (tree-height right)))
left
right))
(define (reverse-combine key val right left)
(combine key val left right))
;; ----------------------------------------
(define (insert t key val)
(cond
[(not t) (combine key val #f #f)]
[(fx< key (node-key t))
(insert-to t key val
node-left
node-right
combine
rotate-right)]
[(fx< (node-key t) key)
(insert-to t key val
node-right
node-left
reverse-combine
rotate-left)]
[else
(node key val
(node-height t)
(node-left t)
(node-right t))]))
;; Like insert, but inserts to a child, where `node-to'
;; determines the side where the child is added,`node-other'
;; is the other side, and `comb' builds the new tree gven the
;; two new children.
(define-syntax-rule (insert-to t new-key new-val node-to node-other comb rotate)
(begin
;; Insert into the `node-to' child:
(define new-to (insert (node-to t) new-key new-val))
(define new-other (node-other t))
(define new-t (comb (node-key t) (node-val t) new-to new-other))
;; Check for rotation:
(define to-height (tree-height new-to))
(define other-height (tree-height new-other))
(if ((fx- to-height other-height) . fx= . 2)
(rotate new-t)
new-t)))
(define (delete t key)
(cond
[(not t) #f]
[(Br? t) (Br-count t)]
[else 1]))
(define (intmap-ref t key)
(cond
[(Br? t)
(if (fx<= key (Br-prefix t))
(intmap-ref (Br-left t) key)
(intmap-ref (Br-right t) key))]
[(Lf? t)
(if (fx= key (Lf-key t))
(Lf-value t)
(not-found key))]
[else (not-found key)]))
(define (not-found key)
(error 'intmap-ref "not found: ~e" key))
(define (intmap-set t key val)
(cond
[(Br? t)
(let ([p (Br-prefix t)]
[m (Br-mask t)])
(cond
[(not (match-prefix? key p m))
(join key (Lf key val) p t)]
[(fx<= key p)
(br p m (intmap-set (Br-left t) key val) (Br-right t))]
[else
(br p m (Br-left t) (intmap-set (Br-right t) key val))]))]
[(Lf? t)
(let ([j (Lf-key t)])
(cond
[(not (fx= j key))
(join key (Lf key val) j t)]
[else
(Lf key val)]))]
[else
(Lf key val)]))
(define (join p0 t0 p1 t1)
(let* ([m (branching-bit p0 p1)]
[p (mask p0 m)])
(if (fx<= p0 p1)
(br p m t0 t1)
(br p m t1 t0))))
(define (intmap-remove t key)
(cond
[(Br? t)
(let ([p (Br-prefix t)]
[m (Br-mask t)])
(cond
[(not (match-prefix? key p m))
t]
[(fx<= key p)
(br/check-left p m (intmap-remove (Br-left t) key) (Br-right t))]
[(fx< key (node-key t))
(delete-from t key
node-left
node-right
combine
rotate-left)]
[(fx< (node-key t) key)
(delete-from t key
node-right
node-left
reverse-combine
rotate-right)]
[else
(define l (node-left t))
(define r (node-right t))
(cond
[(not l) r]
[(not r) l]
[else
(br/check-right p m (Br-left t) (intmap-remove (Br-right t) key))]))]
[(Lf? t)
(if (fx= key (Lf-key t))
#f
t)]
[else
#f]))
(delete-here t node-left node-right combine rotate-left)])]))
;; bit twiddling
(define-syntax-rule (match-prefix? h p m)
(fx= (mask h m) p))
(define-syntax-rule (delete-from t key node-to node-other comb rotate)
(begin
;; Delete from the `node-to' child:
(define new-to (delete (node-to t) key))
(define new-other (node-other t))
(define-syntax-rule (mask h m)
(fxand (fxior h (fx- m 1)) (fxnot m)))
(define new-t (comb (node-key t) (node-val t) new-to new-other))
(define-syntax-rule (branching-bit p m)
(highest-set-bit (fxxor p m)))
;; Check for rotation:
(define to-height (tree-height new-to))
(define other-height (tree-height new-other))
(if ((fx- to-height other-height) . fx= . -2)
(rotate new-t)
new-t)))
(define-syntax (if-64-bit? stx)
(syntax-case stx ()
[(_ 64-mode 32-mode)
(if (eqv? 64 (system-type 'word))
#'64-mode
#'32-mode)]))
(define-syntax-rule (delete-here t node-from node-other comb rotate)
(begin
;; Delete by moving from `from` to `other`
(define from (node-from t))
(define new-t
(let loop ([end from])
(cond
[(node-other end)
=> (lambda (e) (loop e))]
[else
(define key (node-key end))
(define new-from (delete from key))
(comb key (node-val end) new-from (node-other t))])))
(define-syntax-rule (highest-set-bit x1)
(let* ([x2 (fxior x1 (fxrshift x1 1))]
[x3 (fxior x2 (fxrshift x2 2))]
[x4 (fxior x3 (fxrshift x3 4))]
[x5 (fxior x4 (fxrshift x4 8))]
[x6 (fxior x5 (fxrshift x5 16))]
[x7 (if-64-bit?
(fxior x6 (fxrshift x6 3))
x6)])
(fxxor x7 (fxrshift x7 1))))
;; Check for rotation:
(define from-height (tree-height (node-from new-t)))
(define other-height (tree-height (node-other new-t)))
(if ((fx- from-height other-height) . fx= . -2)
(rotate new-t)
new-t)))
;; basic utils
(define (br p m l r)
(let ([c (fx+ (intmap-count l) (intmap-count r))])
(Br c p m l r)))
(define-syntax-rule (define-rotate rotate node-to node-other comb)
(begin
;; Helper rotate function:
(define (rotate t)
(define to (node-to t))
(define to-balance (fx- (tree-height (node-to to))
(tree-height (node-other to))))
(cond
[(to-balance . fx< . 0)
(double-rotate t)]
[else
(single-rotate t)]))
(define (br/check-left p m l r)
(if l
(br p m l r)
r))
;; Helper double-rotate function:
(define (double-rotate t)
(define orange (node-to t))
(define yellow (node-other orange))
(define A (node-to orange))
(define B (node-to yellow))
(define C (node-other yellow))
(define D (node-other t))
(single-rotate (comb (node-key t)
(node-val t)
(comb (node-key yellow)
(node-val yellow)
(comb (node-key orange)
(node-val orange)
A
B)
C)
D)))
(define (br/check-right p m l r)
(if r
(br p m l r)
l))
;; Helper single-rotate function:
(define (single-rotate t)
(define yellow (node-to t))
(comb (node-key yellow)
(node-val yellow)
(node-to yellow)
(comb (node-key t)
(node-val t)
(node-other yellow)
(node-other t))))))
(define-rotate rotate-right node-left node-right combine)
(define-rotate rotate-left node-right node-left reverse-combine)
;; ----------------------------------------
(define empty-intmap #f)
(define (intmap-count im)
(cond
[(not im) 0]
[else (fx+ 1
(intmap-count (node-left im))
(intmap-count (node-right im)))]))
(define (intmap-ref im key)
(cond
[(not im)
(error 'intmap-ref "not found: ~e" key)]
[(fx< key (node-key im))
(intmap-ref (node-left im) key)]
[(fx< (node-key im) key)
(intmap-ref (node-right im) key)]
[else
(node-val im)]))
(define (intmap-set im key val)
(insert im key val))
(define (intmap-remove im key)
(delete im key))
;; ----------------------------------------
#;
(module+ main
(require racket/match
racket/list
rackunit)
(define (inorder t accum)
(match t
[#f accum]
[(node k v h l r)
(inorder l (cons v (inorder r accum)))]))
(define (insert-all l)
(for/fold ([t #f]) ([i (in-list l)])
(insert t i (number->string i))))
(define (delete-all t l)
(let loop ([t t] [l l])
(cond
[(null? l) t]
[else
(define new-t (delete t (car l)))
(check-equal? (map string->number (inorder new-t null))
(sort (cdr l) <))
(loop new-t (cdr l))])))
(define (check-ok? l)
(define t (insert-all l))
(check-equal? (map string->number (inorder t null))
(sort l <))
(check-equal? #f
(delete-all t l)))
(check-ok? '(1 2 3 4 5 6 7 8))
(check-ok? '(-1 -2 -3 -4 -5 -6 -7 -8))
(check-ok? (for/list ([i (in-range 128)]) i))
(check-ok? (reverse (for/list ([i (in-range 128)]) i)))
(for ([i 10])
(check-ok? (shuffle '(1 2 3 4 5 6 7 8 9 10 11 12 13))))
"tests passed")

1
racket/src/schemify/main.rkt
View File

@ -25,6 +25,7 @@
make-path->compiled-path
compiled-path->path
interpreter-link!
interpretable-jitified-linklet
interpret-linklet

22
racket/src/schemify/schemify.rkt
View File

@ -76,7 +76,7 @@
;; An import ABI is a list of list of booleans, parallel to the
;; linklet imports, where #t to means that a value is expected, and #f
;; means that a variable (which boxes a value) is expected.
(define (schemify-linklet lk serializable? datum-intern? for-jitify? allow-set!-undefined?
(define (schemify-linklet lk serializable? datum-intern? for-interp? allow-set!-undefined?
unsafe-mode? enforce-constant? allow-inline? no-prompt?
prim-knowns primitives get-import-knowns import-keys)
(with-deterministic-gensym
@ -137,7 +137,7 @@
;; Schemify the body, collecting information about defined names:
(define-values (new-body defn-info mutated)
(schemify-body* bodys/constants-lifted prim-knowns primitives imports exports
for-jitify? allow-set!-undefined? add-import! #f
for-interp? allow-set!-undefined? add-import! #f
unsafe-mode? enforce-constant? allow-inline? no-prompt?))
(define all-grps (append grps (reverse new-grps)))
(values
@ -195,7 +195,7 @@
new-body))
(define (schemify-body* l prim-knowns primitives imports exports
for-jitify? allow-set!-undefined? add-import!
for-interp? allow-set!-undefined? add-import!
for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt?)
;; Keep simple checking efficient by caching results
(define simples (make-hasheq))
@ -231,7 +231,7 @@
#:when (hash-ref exports (unwrap id) #f))
(make-set-variable id exports knowns mutated)))
(define (make-expr-defns es)
(if (or for-jitify? for-cify?)
(if (or for-interp? for-cify?)
(reverse es)
(for/list ([e (in-list (reverse es))])
(make-expr-defn e))))
@ -253,7 +253,7 @@
prim-knowns primitives knowns mutated imports exports simples
allow-set!-undefined?
add-import!
for-cify? for-jitify?
for-cify? for-interp?
unsafe-mode? allow-inline? no-prompt?
(if (and no-prompt? (null? (cdr l)))
'tail
@ -289,7 +289,7 @@
[(null? ids) (if next-k
(next-k accum-exprs accum-ids next-knowns)
(loop (cdr l) mut-l accum-exprs accum-ids next-knowns))]
[(or (or for-jitify? for-cify?)
[(or (or for-interp? for-cify?)
(via-variable-mutated-state? (hash-ref mutated (unwrap (car ids)) #f)))
(define id (unwrap (car ids)))
(cond
@ -331,7 +331,7 @@
(for/list ([id (in-list ids)])
(make-define-variable id exports knowns mutated extra-variables)))
(cons
(if for-jitify?
(if for-interp?
expr
(make-expr-defn expr))
(append defns (loop (cdr l) mut-l null null knowns)))])))
@ -436,7 +436,7 @@
;; a 'too-early state in `mutated` for a `letrec`-bound variable can be
;; effectively canceled with a mapping in `knowns`.
(define (schemify v prim-knowns primitives knowns mutated imports exports simples allow-set!-undefined? add-import!
for-cify? for-jitify? unsafe-mode? allow-inline? no-prompt? wcm-state)
for-cify? for-interp? unsafe-mode? allow-inline? no-prompt? wcm-state)
;; `wcm-state` is one of: 'tail (= unknown), 'fresh (= no marks), or 'marked (= some marks)
(let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [wcm-state wcm-state] [v v])
(define (schemify v wcm-state)
@ -460,7 +460,7 @@
,make2
,?2
,make-acc/muts ...)))
#:guard (not (or for-jitify? for-cify?))
#:guard (not (or for-interp? for-cify?))
(define new-seq
(struct-convert v prim-knowns knowns imports mutated
(lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) no-prompt?))
@ -745,7 +745,7 @@
(define (inline-field-access k s-rator im args)
;; For imported accessors or for JIT mode, inline the
;; selector with an `unsafe-struct?` test plus `unsafe-struct*-ref`.
(define type-id (and (or im for-jitify?)
(define type-id (and (or im for-interp?)
(pair? args)
(null? (cdr args))
(inline-type-id k im add-import! mutated imports)))
@ -759,7 +759,7 @@
sel)]
[else #f]))
(define (inline-field-mutate k s-rator im args)
(define type-id (and (or im for-jitify?)
(define type-id (and (or im for-interp?)
(pair? args)
(pair? (cdr args))
(null? (cddr args))