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] [name any/c #f]
[import-keys #f #f] [import-keys #f #f]
[get-import #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)) 'use-prompt 'uninterned-literal))
'(serializable)]) '(serializable)])
linklet?] linklet?]
@ -130,7 +130,7 @@ otherwise.}
[get-import (or/c #f (any/c . -> . (values (or/c linklet? instance? #f) [get-import (or/c #f (any/c . -> . (values (or/c linklet? instance? #f)
(or/c vector? #f)))) (or/c vector? #f))))
#f] #f]
[options (listof (or/c 'serializable 'unsafe 'static [options (listof (or/c 'serializable 'unsafe 'static 'quick
'use-prompt 'uninterned-literal)) 'use-prompt 'uninterned-literal))
'(serializable)]) '(serializable)])
(values linklet? vector?)])]{ (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 the performance of references within the linklet to defined and
imported variables. 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 If @racket['use-prompt] is included in @racket[options], then
instantiating resulting linklet always wraps a prompt around each instantiating resulting linklet always wraps a prompt around each
definition and immediate expression in the linklet. Otherwise, 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]. @exnraise[exn:fail:contract].
@history[#:changed "7.1.0.8" @elem{Added the @racket['use-prompt] option.} @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?] @defproc*[([(recompile-linklet [linklet linklet?]
[name any/c #f] [name any/c #f]
[import-keys #f #f] [import-keys #f #f]
[get-import #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)) 'use-prompt 'uninterned-literal))
'(serializable)]) '(serializable)])
linklet?] linklet?]
@ -230,7 +236,7 @@ The symbols in @racket[options] must be distinct, otherwise
(or/c vector? #f))) (or/c vector? #f)))
#f) #f)
(lambda (import-key) (values #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)) 'use-prompt 'uninterned-literal))
'(serializable)]) '(serializable)])
(values linklet? vector?)])]{ (values linklet? vector?)])]{
@ -240,7 +246,8 @@ and potentially optimizes it further.
@history[#:changed "7.1.0.6" @elem{Added the @racket[options] argument.} @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.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?]{ @defproc[(eval-linklet [linklet linklet?]) linklet?]{

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

@ -508,7 +508,7 @@
(set! f #f)) (set! f #f))
;; ---------------------------------------- ;; ----------------------------------------
;; Check mutation of direct-called keyword procedure ;; Check name of keyword procedure
(let () (let ()
(define (f1 #:x x) (list x)) (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`: ;; Check that constant folding doesn't go wrong for `unsafe-fxlshift`:
(test #t fixnum? (if (eqv? 64 (system-type 'word)) (test #t procedure? (lambda ()
(unsafe-fxlshift 1 62) (if (eqv? 64 (system-type 'word))
(unsafe-fxlshift 1 30))) (unsafe-fxlshift 1 60)
(test #t zero? (if (eqv? 64 (system-type 'word)) (unsafe-fxlshift 1 28))))
(unsafe-fxlshift 1 63) (test #t procedure? (lambda ()
(unsafe-fxlshift 1 31))) (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 ;; 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 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 * Machine-code mode --- The compiled form of a module is machine code
generated by compiling either whole linklets (for small enough 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 is 10000. Setting `PLT_CS_COMPILE_LIMIT` to 0 effectively turns
the implementation into a pure interpreter. 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 * JIT mode --- The compiled form of a module is an S-expression where
individual `lambda`s are compiled on demand. 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" compiled ".zo" files in this mode are written to a "cs"
subdirectory of "compiled". 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, 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 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` an SQLite database) of machine-code forms. Set the `PLT_JIT_CACHE`

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

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

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

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

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

@ -523,6 +523,15 @@
name)]) name)])
p)) 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) (define (extract-wrapper-procedure-name p)
(let ([name (wrapper-procedure-data p)]) (let ([name (wrapper-procedure-data p)])
(cond (cond

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

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

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

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

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

@ -188,7 +188,7 @@
#:serializable? #t #:serializable? #t
#:module-prompt? #t #:module-prompt? #t
#:module-use*s module-use*s #:module-use*s module-use*s
#:cross-linklet-inlining? #t #:optimize-linklet? #t
#:load-modules? #t #:load-modules? #t
#:namespace ns)) #:namespace ns))
(values phase (cons linklet new-module-use*s)))) (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) #:other-form-callback (lambda (s cctx)
(set! purely-functional? #f) (set! purely-functional? #f)
(compile-top-level-require s cctx)) (compile-top-level-require s cctx))
#:cross-linklet-inlining? (not single-expression?))) #:optimize-linklet? (not single-expression?)))
(define (add-metadata ht) (define (add-metadata ht)
(let* ([ht (hash-set ht 'original-phase phase)] (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 *static_symbol;
static Scheme_Object *use_prompt_symbol; static Scheme_Object *use_prompt_symbol;
static Scheme_Object *uninterned_literal_symbol; static Scheme_Object *uninterned_literal_symbol;
static Scheme_Object *quick_symbol;
static Scheme_Object *constant_symbol; static Scheme_Object *constant_symbol;
static Scheme_Object *consistent_symbol; static Scheme_Object *consistent_symbol;
static Scheme_Object *noncm_symbol; static Scheme_Object *noncm_symbol;
@ -102,11 +103,13 @@ void scheme_init_linklet(Scheme_Startup_Env *env)
REGISTER_SO(static_symbol); REGISTER_SO(static_symbol);
REGISTER_SO(use_prompt_symbol); REGISTER_SO(use_prompt_symbol);
REGISTER_SO(uninterned_literal_symbol); REGISTER_SO(uninterned_literal_symbol);
REGISTER_SO(quick_symbol);
serializable_symbol = scheme_intern_symbol("serializable"); serializable_symbol = scheme_intern_symbol("serializable");
unsafe_symbol = scheme_intern_symbol("unsafe"); unsafe_symbol = scheme_intern_symbol("unsafe");
static_symbol = scheme_intern_symbol("static"); static_symbol = scheme_intern_symbol("static");
use_prompt_symbol = scheme_intern_symbol("use-prompt"); use_prompt_symbol = scheme_intern_symbol("use-prompt");
uninterned_literal_symbol = scheme_intern_symbol("uninterned-literal"); uninterned_literal_symbol = scheme_intern_symbol("uninterned-literal");
quick_symbol = scheme_intern_symbol("quick");
REGISTER_SO(constant_symbol); REGISTER_SO(constant_symbol);
REGISTER_SO(consistent_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 static_mode = *_static_mode;
int use_prompt_mode = 0; int use_prompt_mode = 0;
int uninterned_literal_mode = 0; int uninterned_literal_mode = 0;
int quick_mode = 0;
while (SCHEME_PAIRP(flags)) { while (SCHEME_PAIRP(flags)) {
flag = SCHEME_CAR(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) if (uninterned_literal_mode && !redundant)
redundant = flag; redundant = flag;
uninterned_literal_mode = 1; uninterned_literal_mode = 1;
} else if (SAME_OBJ(flag, quick_symbol)) {
if (quick_mode && !redundant)
redundant = flag;
quick_mode = 1;
} else } else
break; break;
flags = SCHEME_CDR(flags); flags = SCHEME_CDR(flags);
@ -394,7 +402,7 @@ static void parse_compile_options(const char *who, int arg_pos,
if (!SCHEME_NULLP(flags)) if (!SCHEME_NULLP(flags))
scheme_wrong_contract("compile-linklet", 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); arg_pos, argc, argv);
if (redundant) if (redundant)

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

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

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

@ -10,9 +10,11 @@
stack-remove stack-remove
push-stack push-stack
(struct-out stack-info) make-stack-info
stack-info-local-use-map
stack->pos stack->pos
stack-info-branch stack-info-branch
stack-info-branch-need-clears?
stack-info-merge! stack-info-merge!
stack-info-forget! stack-info-forget!
stack-info-non-tail!) stack-info-non-tail!)
@ -72,7 +74,17 @@
closure-map ; hash table to collect variables byond boundary to capture 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 [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 [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 ;; 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 ;; 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))) (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 ;; We only need to remove from the environment if there's a
;; non-tail call later where the binding would be retained ;; non-tail call later where the binding would be retained
;; across the call ;; across the call.
(if (i . < . (stack-info-non-tail-at-depth stk-i)) (if (stack-info-non-tail-call-later? stk-i)
(box pos) (box pos)
pos)])])) pos)])]))
@ -124,7 +136,10 @@
(stack-info-closure-map stk-i) (stack-info-closure-map stk-i)
(stack-info-use-map stk-i) (stack-info-use-map stk-i)
#hasheq() #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 ;; Merge branches back together, returning the set of all bindings
;; that has last uses across all branches. The returned information ;; 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)) (define local-use-map (stack-info-local-use-map stk-i))
(when local-use-map (when local-use-map
(set-stack-info-local-use-map! stk-i (hash-set local-use-map pos #t))) (set-stack-info-local-use-map! stk-i (hash-set local-use-map pos #t)))
(set-stack-info-non-tail-at-depth! stk-i (set-stack-info-non-tail-call-later?! stk-i
(max (stack-info-non-tail-at-depth stk-i) (or (stack-info-non-tail-call-later? stk-i)
(stack-info-non-tail-at-depth branch-stk-i))))) (stack-info-non-tail-call-later? branch-stk-i)))))
all-clear) all-clear)
;; Indicate that some bindings are "popped" from the stack, which ;; Indicate that some bindings are "popped" from the stack, which
;; means that they no longer count as used, etc. ;; means that they no longer count as used, etc.
(define (stack-info-forget! stk-i stack-depth start-pos len) (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) (when (stack-info-use-map stk-i)
(for ([i (in-range len)]) (for ([i (in-range len)])
(define pos (+ start-pos i)) (define pos (+ start-pos i))
@ -163,6 +175,4 @@
;; Record the current stack depth at a non-tail call. ;; Record the current stack depth at a non-tail call.
(define (stack-info-non-tail! stk-i stack-depth) (define (stack-info-non-tail! stk-i stack-depth)
(set-stack-info-non-tail-at-depth! stk-i (set-stack-info-non-tail-call-later?! stk-i #t))
(max (stack-info-non-tail-at-depth stk-i)
stack-depth)))

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 (require racket/fixnum
(for-syntax racket/base)) (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 (provide empty-intmap
intmap-count intmap-count ; not constant-time
intmap-ref intmap-ref
intmap-set intmap-set
intmap-remove) 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 (cond
[(not t) #f] [(not t) #f]
[(Br? t) (Br-count t)] [(fx< key (node-key t))
[else 1])) (delete-from t key
node-left
(define (intmap-ref t key) node-right
(cond combine
[(Br? t) rotate-left)]
(if (fx<= key (Br-prefix t)) [(fx< (node-key t) key)
(intmap-ref (Br-left t) key) (delete-from t key
(intmap-ref (Br-right t) key))] node-right
[(Lf? t) node-left
(if (fx= key (Lf-key t)) reverse-combine
(Lf-value t) rotate-right)]
(not-found key))] [else
[else (not-found key)])) (define l (node-left t))
(define r (node-right t))
(define (not-found key) (cond
(error 'intmap-ref "not found: ~e" key)) [(not l) r]
[(not r) l]
(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))]
[else [else
(br/check-right p m (Br-left t) (intmap-remove (Br-right t) key))]))] (delete-here t node-left node-right combine rotate-left)])]))
[(Lf? t)
(if (fx= key (Lf-key t))
#f
t)]
[else
#f]))
;; bit twiddling (define-syntax-rule (delete-from t key node-to node-other comb rotate)
(define-syntax-rule (match-prefix? h p m) (begin
(fx= (mask h m) p)) ;; Delete from the `node-to' child:
(define new-to (delete (node-to t) key))
(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-syntax-rule (mask h m) (define-syntax-rule (delete-here t node-from node-other comb rotate)
(fxand (fxior h (fx- m 1)) (fxnot m))) (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 (branching-bit p m) ;; Check for rotation:
(highest-set-bit (fxxor p m))) (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)))
(define-syntax (if-64-bit? stx) (define-syntax-rule (define-rotate rotate node-to node-other comb)
(syntax-case stx () (begin
[(_ 64-mode 32-mode) ;; Helper rotate function:
(if (eqv? 64 (system-type 'word)) (define (rotate t)
#'64-mode (define to (node-to t))
#'32-mode)])) (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-syntax-rule (highest-set-bit x1) ;; Helper double-rotate function:
(let* ([x2 (fxior x1 (fxrshift x1 1))] (define (double-rotate t)
[x3 (fxior x2 (fxrshift x2 2))] (define orange (node-to t))
[x4 (fxior x3 (fxrshift x3 4))] (define yellow (node-other orange))
[x5 (fxior x4 (fxrshift x4 8))] (define A (node-to orange))
[x6 (fxior x5 (fxrshift x5 16))] (define B (node-to yellow))
[x7 (if-64-bit? (define C (node-other yellow))
(fxior x6 (fxrshift x6 3)) (define D (node-other t))
x6)]) (single-rotate (comb (node-key t)
(fxxor x7 (fxrshift x7 1)))) (node-val t)
(comb (node-key yellow)
(node-val yellow)
(comb (node-key orange)
(node-val orange)
A
B)
C)
D)))
;; 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))))))
;; basic utils (define-rotate rotate-right node-left node-right combine)
(define (br p m l r) (define-rotate rotate-left node-right node-left reverse-combine)
(let ([c (fx+ (intmap-count l) (intmap-count r))])
(Br c p m l r)))
(define (br/check-left p m l r) ;; ----------------------------------------
(if l
(br p m l r)
r))
(define (br/check-right p m l r) (define empty-intmap #f)
(if r
(br p m l r) (define (intmap-count im)
l)) (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 make-path->compiled-path
compiled-path->path compiled-path->path
interpreter-link!
interpretable-jitified-linklet interpretable-jitified-linklet
interpret-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 ;; 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 ;; linklet imports, where #t to means that a value is expected, and #f
;; means that a variable (which boxes a value) is expected. ;; 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? unsafe-mode? enforce-constant? allow-inline? no-prompt?
prim-knowns primitives get-import-knowns import-keys) prim-knowns primitives get-import-knowns import-keys)
(with-deterministic-gensym (with-deterministic-gensym
@ -137,7 +137,7 @@
;; Schemify the body, collecting information about defined names: ;; Schemify the body, collecting information about defined names:
(define-values (new-body defn-info mutated) (define-values (new-body defn-info mutated)
(schemify-body* bodys/constants-lifted prim-knowns primitives imports exports (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?)) unsafe-mode? enforce-constant? allow-inline? no-prompt?))
(define all-grps (append grps (reverse new-grps))) (define all-grps (append grps (reverse new-grps)))
(values (values
@ -195,7 +195,7 @@
new-body)) new-body))
(define (schemify-body* l prim-knowns primitives imports exports (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?) for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt?)
;; Keep simple checking efficient by caching results ;; Keep simple checking efficient by caching results
(define simples (make-hasheq)) (define simples (make-hasheq))
@ -231,7 +231,7 @@
#:when (hash-ref exports (unwrap id) #f)) #:when (hash-ref exports (unwrap id) #f))
(make-set-variable id exports knowns mutated))) (make-set-variable id exports knowns mutated)))
(define (make-expr-defns es) (define (make-expr-defns es)
(if (or for-jitify? for-cify?) (if (or for-interp? for-cify?)
(reverse es) (reverse es)
(for/list ([e (in-list (reverse es))]) (for/list ([e (in-list (reverse es))])
(make-expr-defn e)))) (make-expr-defn e))))
@ -253,7 +253,7 @@
prim-knowns primitives knowns mutated imports exports simples prim-knowns primitives knowns mutated imports exports simples
allow-set!-undefined? allow-set!-undefined?
add-import! add-import!
for-cify? for-jitify? for-cify? for-interp?
unsafe-mode? allow-inline? no-prompt? unsafe-mode? allow-inline? no-prompt?
(if (and no-prompt? (null? (cdr l))) (if (and no-prompt? (null? (cdr l)))
'tail 'tail
@ -289,7 +289,7 @@
[(null? ids) (if next-k [(null? ids) (if next-k
(next-k accum-exprs accum-ids next-knowns) (next-k accum-exprs accum-ids next-knowns)
(loop (cdr l) mut-l 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))) (via-variable-mutated-state? (hash-ref mutated (unwrap (car ids)) #f)))
(define id (unwrap (car ids))) (define id (unwrap (car ids)))
(cond (cond
@ -331,7 +331,7 @@
(for/list ([id (in-list ids)]) (for/list ([id (in-list ids)])
(make-define-variable id exports knowns mutated extra-variables))) (make-define-variable id exports knowns mutated extra-variables)))
(cons (cons
(if for-jitify? (if for-interp?
expr expr
(make-expr-defn expr)) (make-expr-defn expr))
(append defns (loop (cdr l) mut-l null null knowns)))]))) (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 ;; a 'too-early state in `mutated` for a `letrec`-bound variable can be
;; effectively canceled with a mapping in `knowns`. ;; effectively canceled with a mapping in `knowns`.
(define (schemify v prim-knowns primitives knowns mutated imports exports simples allow-set!-undefined? add-import! (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) ;; `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]) (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [wcm-state wcm-state] [v v])
(define (schemify v wcm-state) (define (schemify v wcm-state)
@ -460,7 +460,7 @@
,make2 ,make2
,?2 ,?2
,make-acc/muts ...))) ,make-acc/muts ...)))
#:guard (not (or for-jitify? for-cify?)) #:guard (not (or for-interp? for-cify?))
(define new-seq (define new-seq
(struct-convert v prim-knowns knowns imports mutated (struct-convert v prim-knowns knowns imports mutated
(lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) no-prompt?)) (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) (define (inline-field-access k s-rator im args)
;; For imported accessors or for JIT mode, inline the ;; For imported accessors or for JIT mode, inline the
;; selector with an `unsafe-struct?` test plus `unsafe-struct*-ref`. ;; 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) (pair? args)
(null? (cdr args)) (null? (cdr args))
(inline-type-id k im add-import! mutated imports))) (inline-type-id k im add-import! mutated imports)))
@ -759,7 +759,7 @@
sel)] sel)]
[else #f])) [else #f]))
(define (inline-field-mutate k s-rator im args) (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? args)
(pair? (cdr args)) (pair? (cdr args))
(null? (cddr args)) (null? (cddr args))