diff --git a/pkgs/racket-doc/scribblings/reference/linklet.scrbl b/pkgs/racket-doc/scribblings/reference/linklet.scrbl index 287dcc76e2..71989a7461 100644 --- a/pkgs/racket-doc/scribblings/reference/linklet.scrbl +++ b/pkgs/racket-doc/scribblings/reference/linklet.scrbl @@ -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?]{ diff --git a/pkgs/racket-test-core/tests/racket/procs.rktl b/pkgs/racket-test-core/tests/racket/procs.rktl index 6262f4127c..2e920463b2 100644 --- a/pkgs/racket-test-core/tests/racket/procs.rktl +++ b/pkgs/racket-test-core/tests/racket/procs.rktl @@ -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)) diff --git a/pkgs/racket-test-core/tests/racket/unsafe.rktl b/pkgs/racket-test-core/tests/racket/unsafe.rktl index e8834df520..c559e614d1 100644 --- a/pkgs/racket-test-core/tests/racket/unsafe.rktl +++ b/pkgs/racket-test-core/tests/racket/unsafe.rktl @@ -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 diff --git a/racket/src/cs/README.txt b/racket/src/cs/README.txt index 9eacb1cbab..6cf99e6b26 100644 --- a/racket/src/cs/README.txt +++ b/racket/src/cs/README.txt @@ -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` diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 5a5cc3f91d..66dcc4d4c2 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -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)))) @@ -248,12 +254,14 @@ (unsafe-hash-seal! primitives) ;; 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)) diff --git a/racket/src/cs/linklet/check.ss b/racket/src/cs/linklet/check.ss index d195bc8a3a..9c0def8b1b 100644 --- a/racket/src/cs/linklet/check.ss +++ b/racket/src/cs/linklet/check.ss @@ -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)]))) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index d8a9a673a8..f7f870d7d2 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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 diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index 68e037f97c..dcc0d19fa2 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/racket/src/cs/rumble/procedure.ss @@ -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 diff --git a/racket/src/cs/schemify.sls b/racket/src/cs/schemify.sls index 6534ba35a8..46b7650704 100644 --- a/racket/src/cs/schemify.sls +++ b/racket/src/cs/schemify.sls @@ -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? diff --git a/racket/src/expander/compile/form.rkt b/racket/src/expander/compile/form.rkt index 6e187928df..b59b6404be 100644 --- a/racket/src/expander/compile/form.rkt +++ b/racket/src/expander/compile/form.rkt @@ -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)] diff --git a/racket/src/expander/compile/recompile.rkt b/racket/src/expander/compile/recompile.rkt index 3cf18ddf52..ec9369a1d4 100644 --- a/racket/src/expander/compile/recompile.rkt +++ b/racket/src/expander/compile/recompile.rkt @@ -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)))) diff --git a/racket/src/expander/compile/top.rkt b/racket/src/expander/compile/top.rkt index 2e92dee40e..e13637e1c9 100644 --- a/racket/src/expander/compile/top.rkt +++ b/racket/src/expander/compile/top.rkt @@ -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)] diff --git a/racket/src/racket/src/linklet.c b/racket/src/racket/src/linklet.c index cb4c270d0a..3d71b5ab17 100644 --- a/racket/src/racket/src/linklet.c +++ b/racket/src/racket/src/linklet.c @@ -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) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index f5cc4930f0..0b9281a05b 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -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" diff --git a/racket/src/schemify/interp-stack.rkt b/racket/src/schemify/interp-stack.rkt index 3c4adabcb1..de6c7da9b4 100644 --- a/racket/src/schemify/interp-stack.rkt +++ b/racket/src/schemify/interp-stack.rkt @@ -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)) diff --git a/racket/src/schemify/interpret.rkt b/racket/src/schemify/interpret.rkt index c190e13bc1..837168e0c1 100644 --- a/racket/src/schemify/interpret.rkt +++ b/racket/src/schemify/interpret.rkt @@ -25,14 +25,36 @@ ;; explicit operations to remove mappings from the environment as ;; needed to implement space safety. -(provide interpretable-jitified-linklet +(provide interpreter-link! + interpretable-jitified-linklet interpret-linklet) (struct indirect (pos element)) (struct boxed (pos)) (struct boxed/check boxed ()) -(define (interpretable-jitified-linklet linklet-e strip-annotations) +(define primitives '#hasheq()) +(define strip-annotations (lambda (e) e)) +(define variable-ref (lambda (var) (unbox var))) +(define variable-ref/no-check (lambda (var) (unbox var))) +(define variable-set! (lambda (var v) (set-box! var v))) +(define variable-set!/define (lambda (var v) (set-box! var v))) +(define make-interp-procedure* (lambda (proc mask name) proc)) + +(define (interpreter-link! prims + strip + var-ref var-ref/no-check + var-set! var-set!/def + make-proc) + (set! primitives prims) + (set! strip-annotations strip) + (set! variable-ref var-ref) + (set! variable-ref/no-check var-ref/no-check) + (set! variable-set! var-set!) + (set! variable-set!/define var-set!/def) + (set! make-interp-procedure* make-proc)) + +(define (interpretable-jitified-linklet linklet-e serializable?) ;; Return a compiled linklet in two parts: a vector expression for ;; constants to be run once, and a expression for the linklet body. @@ -69,7 +91,7 @@ num-body-vars compiled-body)] [`(let* ,bindings ,body) - (define bindings-stk-i (stack-info #f #hasheq() #f #f 0)) + (define bindings-stk-i (make-stack-info)) (let loop ([bindings bindings] [elem 0] [env '#hasheq()] [accum '()]) (cond [(null? bindings) @@ -93,12 +115,15 @@ ;; not a primitive '#%path] [else - (compile-expr rhs env 1 bindings-stk-i #t)]) + (compile-expr rhs env 1 bindings-stk-i #t '#hasheq())]) accum))))]))])) (define (compile-linklet-body v env stack-depth) (match v [`(lambda ,args . ,body) + ;; Gather all `set!`ed variables, since they'll need to be boxed + ;; if they're not top-level `define`s + (define mutated (extract-list-mutated body '#hasheq())) ;; The `args` here are linklet import and export variables (define num-args (length args)) (define args-env @@ -125,17 +150,17 @@ (loop e env num-body-vars))] [`,_ (values env num-body-vars)])))) (define body-stack-depth (+ num-body-vars num-args stack-depth)) - ;; This `stack-info` is mutated as expressiones are compiled, + ;; This `stack-info` is mutated as expressions are compiled, ;; because that's more convenient than threading it through as ;; both an argument and a result - (define stk-i (stack-info #f #hasheq() #f #f 0)) + (define stk-i (make-stack-info #:track-use? #t)) (define new-body - (compile-top-body body body-env body-stack-depth stk-i)) + (compile-top-body body body-env body-stack-depth stk-i mutated)) (values new-body num-body-vars)])) ;; Like `compile-body`, but flatten top-level `begin`s - (define (compile-top-body body env stack-depth stk-i) + (define (compile-top-body body env stack-depth stk-i mutated) (define bs (let loop ([body body]) (match body [`() '()] @@ -143,7 +168,7 @@ (loop (append subs rest))] [`(,e . ,rest) (define new-rest (loop rest)) - (cons (compile-expr e env stack-depth stk-i #t) + (cons (compile-expr e env stack-depth stk-i #t mutated) new-rest)]))) (cond [(null? bs) '#(void)] @@ -152,62 +177,66 @@ [else (list->vector (cons 'begin bs))])) - (define (compile-body body env stack-depth stk-i tail?) + (define (compile-body body env stack-depth stk-i tail? mutated) (match body - [`(,e) (compile-expr e env stack-depth stk-i tail?)] + [`(,e) (compile-expr e env stack-depth stk-i tail? mutated)] [`,_ (list->vector - (cons 'begin (compile-list body env stack-depth stk-i tail?)))])) + (cons 'begin (compile-list body env stack-depth stk-i tail? mutated)))])) - (define (compile-list body env stack-depth stk-i tail?) + (define (compile-list body env stack-depth stk-i tail? mutated) (let loop ([body body]) (cond [(null? body) '()] [else (define rest-body (wrap-cdr body)) (define new-rest (loop rest-body)) - (cons (compile-expr (wrap-car body) env stack-depth stk-i (and tail? rest-body)) + (cons (compile-expr (wrap-car body) env stack-depth stk-i (and tail? (null? rest-body)) mutated) new-rest)]))) - (define (compile-expr e env stack-depth stk-i tail?) + (define (compile-expr e env stack-depth stk-i tail? mutated) (match e [`(lambda ,ids . ,body) (define-values (body-env count rest?) - (args->env ids env stack-depth)) + (args->env ids env stack-depth mutated)) (define cmap (make-hasheq)) (define body-stack-depth (+ stack-depth count)) ;; A fresh `stack-info` reflects how a flat closure shifts the ;; coordinates of the variables that it captures; captured ;; variables are added to `cmap` as they are discovered - (define body-stk-i (stack-info stack-depth cmap #hasheq() #f 0)) - (define new-body (compile-body body body-env body-stack-depth body-stk-i #t)) + (define body-stk-i (make-stack-info #:capture-depth stack-depth + #:closure-map cmap + #:track-use? #t)) + (define new-body (compile-body body body-env body-stack-depth body-stk-i #t mutated)) (define rev-cmap (for/hasheq ([(i pos) (in-hash cmap)]) (values (- -1 pos) i))) (vector 'lambda (count->mask count rest?) - (wrap-property e 'inferred-name) + (extract-procedure-wrap-data e) (for/vector #:length (hash-count cmap) ([i (in-range (hash-count cmap))]) (stack->pos (hash-ref rev-cmap i) stk-i)) - new-body)] + (add-boxes/remove-unused new-body ids mutated body-env body-stk-i))] [`(case-lambda [,idss . ,bodys] ...) (define lams (for/list ([ids (in-list idss)] [body (in-list bodys)]) - (compile-expr `(lambda ,ids . ,body) env stack-depth stk-i tail?))) + (compile-expr `(lambda ,ids . ,body) env stack-depth stk-i tail? mutated))) (define mask (for/fold ([mask 0]) ([lam (in-list lams)]) (bitwise-ior mask (interp-match lam [#(lambda ,mask) mask])))) - (define name (wrap-property e 'inferred-name)) - (list->vector (list* 'case-lambda mask name lams))] + (list->vector (list* 'case-lambda mask (extract-procedure-wrap-data e) lams))] [`(let ([,ids ,rhss] ...) . ,body) (define len (length ids)) (define body-env (for/fold ([env env]) ([id (in-list ids)] [i (in-naturals)]) - (hash-set env (unwrap id) (+ stack-depth i)))) + (define u (unwrap id)) + (define pos (+ stack-depth i)) + (hash-set env u (if (hash-ref mutated u #f) (boxed pos) pos)))) (define body-stack-depth (+ stack-depth len)) - (define new-body (compile-body body body-env body-stack-depth stk-i tail?)) + (define c-body (compile-body body body-env body-stack-depth stk-i tail? mutated)) + (define new-body (add-boxes/remove-unused c-body ids mutated body-env stk-i)) (define pos (stack->pos stack-depth stk-i #:nonuse? #t)) (stack-info-forget! stk-i stack-depth pos len) (define new-rhss (list->vector - (compile-list rhss env stack-depth stk-i #f))) + (compile-list rhss env stack-depth stk-i #f mutated))) (or ;; Merge nested `let`s into a `let*` to reduce vector nesting (cond @@ -221,34 +250,34 @@ [#() #f])] [else #f]) (vector 'let pos new-rhss new-body))] - [`(letrec . ,_) (compile-letrec e env stack-depth stk-i tail?)] - [`(letrec* . ,_) (compile-letrec e env stack-depth stk-i tail?)] + [`(letrec . ,_) (compile-letrec e env stack-depth stk-i tail? mutated)] + [`(letrec* . ,_) (compile-letrec e env stack-depth stk-i tail? mutated)] [`(begin . ,vs) - (compile-body vs env stack-depth stk-i tail?)] + (compile-body vs env stack-depth stk-i tail? mutated)] [`(begin0 ,e) - (compile-expr e env stack-depth stk-i tail?)] + (compile-expr e env stack-depth stk-i tail? mutated)] [`(begin0 ,e . ,vs) - (define new-body (compile-body vs env stack-depth stk-i #f)) + (define new-body (compile-body vs env stack-depth stk-i #f mutated)) (vector 'begin0 - (compile-expr e env stack-depth stk-i #f) + (compile-expr e env stack-depth stk-i #f mutated) new-body)] [`($value ,e) - (vector '$value (compile-expr e env stack-depth stk-i #f))] + (vector '$value (compile-expr e env stack-depth stk-i #f mutated))] [`(if ,tst ,thn ,els) (define then-stk-i (stack-info-branch stk-i)) (define else-stk-i (stack-info-branch stk-i)) - (define new-then (compile-expr thn env stack-depth then-stk-i tail?)) - (define new-else (compile-expr els env stack-depth else-stk-i tail?)) + (define new-then (compile-expr thn env stack-depth then-stk-i tail? mutated)) + (define new-else (compile-expr els env stack-depth else-stk-i tail? mutated)) (define all-clear (stack-info-merge! stk-i (list then-stk-i else-stk-i))) (vector 'if - (compile-expr tst env stack-depth stk-i #f) + (compile-expr tst env stack-depth stk-i #f mutated) (add-clears new-then then-stk-i all-clear) (add-clears new-else else-stk-i all-clear))] [`(with-continuation-mark* ,mode ,key ,val ,body) - (define new-body (compile-expr body env stack-depth stk-i tail?)) - (define new-val (compile-expr val env stack-depth stk-i #f)) + (define new-body (compile-expr body env stack-depth stk-i tail? mutated)) + (define new-val (compile-expr val env stack-depth stk-i #f mutated)) (vector 'wcm - (compile-expr key env stack-depth stk-i #f) + (compile-expr key env stack-depth stk-i #f mutated) new-val new-body)] [`(quote ,v) @@ -263,9 +292,9 @@ (vector 'quote v) v))] [`(set! ,id ,rhs) - (compile-assignment id rhs env stack-depth stk-i)] + (compile-assignment id rhs env stack-depth stk-i mutated)] [`(define ,id ,rhs) - (compile-assignment id rhs env stack-depth stk-i)] + (compile-assignment id rhs env stack-depth stk-i mutated)] [`(define-values ,ids ,rhs) (define gen-ids (for/list ([id (in-list ids)]) (deterministic-gensym (unwrap id)))) @@ -279,14 +308,16 @@ env stack-depth stk-i - tail?)] + tail? + mutated)] [`(call-with-values ,proc1 (lambda ,ids . ,body)) (compile-expr `(call-with-values ,proc1 (case-lambda [,ids . ,body])) env stack-depth stk-i - tail?)] + tail? + mutated)] [`(call-with-values (lambda () . ,body) (case-lambda [,idss . ,bodys] ...)) (define body-stk-is (for/list ([body (in-list bodys)]) (stack-info-branch stk-i))) @@ -295,16 +326,17 @@ [body (in-list bodys)] [body-stk-i (in-list body-stk-is)]) (define-values (new-env count rest?) - (args->env ids env stack-depth)) + (args->env ids env stack-depth mutated)) (define new-stack-depth (+ stack-depth count)) - (define new-body (compile-body body new-env new-stack-depth body-stk-i tail?)) + (define c-body (compile-body body new-env new-stack-depth body-stk-i tail? mutated)) + (define new-body (add-boxes/remove-unused c-body ids mutated new-env body-stk-i)) (define pos (stack->pos stack-depth body-stk-i #:nonuse? #t)) (stack-info-forget! body-stk-i stack-depth pos count) (vector (count->mask count rest?) new-body))) (define all-clear (stack-info-merge! stk-i body-stk-is)) (vector 'cwv - (compile-body body env stack-depth stk-i #f) + (compile-body body env stack-depth stk-i #f mutated) (stack->pos stack-depth stk-i #:nonuse? #t) (match e [`(,_ ,_ ,receiver) (wrap-property receiver 'inferred-name)]) @@ -314,16 +346,16 @@ (vector (vector-ref initial-new-clause 0) (add-clears body body-stk-i all-clear))))] [`(call-with-module-prompt (lambda () . ,body)) - (vector 'cwmp0 (compile-body body env stack-depth stk-i tail?))] + (vector 'cwmp0 (compile-body body env stack-depth stk-i tail? mutated))] [`(call-with-module-prompt (lambda () . ,body) ',ids ',constances ,vars ...) (vector 'cwmp - (compile-body body env stack-depth stk-i tail?) + (compile-body body env stack-depth stk-i tail? mutated) ids constances - (compile-list vars env stack-depth stk-i #f))] + (compile-list vars env stack-depth stk-i #f mutated))] [`(variable-set! ,dest-id ,e) (define dest-var (hash-ref env (unwrap dest-id))) - (define new-expr (compile-expr e env stack-depth stk-i #f)) + (define new-expr (compile-expr e env stack-depth stk-i #f mutated)) (vector 'set-variable! (stack->pos dest-var stk-i) new-expr @@ -331,7 +363,7 @@ #f)] [`(variable-set!/define ,dest-id ,e ',constance) (define dest-var (hash-ref env (unwrap dest-id))) - (define new-expr (compile-expr e env stack-depth stk-i #f)) + (define new-expr (compile-expr e env stack-depth stk-i #f mutated)) (vector 'set-variable! (stack->pos dest-var stk-i) new-expr @@ -343,16 +375,21 @@ [`(variable-ref/no-check ,id) (define var (hash-ref env (unwrap id))) (vector 'ref-variable (stack->pos var stk-i))] - [`(#%app ,_ ...) (compile-apply (wrap-cdr e) env stack-depth stk-i tail?)] - [`(,rator ,_ ...) (compile-apply e env stack-depth stk-i tail?)] + [`(#%app ,_ ...) (compile-apply (wrap-cdr e) env stack-depth stk-i tail? mutated)] + [`(,rator ,_ ...) (compile-apply e env stack-depth stk-i tail? mutated)] [`,id (define u (unwrap id)) (define var (hash-ref env u #f)) (cond [(not var) - (if (number? u) - (vector 'quote u) - u)] + (cond + [(number? u) (vector 'quote u)] + [(and (symbol? u) (not serializable?) (hash-ref primitives u #f)) + => (lambda (v) + (cond + [(procedure? v) v] + [else (vector 'quote v)]))] + [else u])] [(indirect? var) (define pos (stack->pos (indirect-pos var) stk-i)) (define elem (indirect-element var)) @@ -365,7 +402,7 @@ [else (stack->pos var stk-i)])])) - (define (compile-letrec e env stack-depth stk-i tail?) + (define (compile-letrec e env stack-depth stk-i tail? mutated) (match e [`(,_ ([,ids ,rhss] ...) . ,body) (define count (length ids)) @@ -376,21 +413,22 @@ (define rhs-env (make-env boxed/check)) (define body-env (make-env boxed)) (define body-stack-depth (+ stack-depth count)) - (define new-body (compile-body body body-env body-stack-depth stk-i tail?)) + (define c-body (compile-body body body-env body-stack-depth stk-i tail? mutated)) (define new-rhss (list->vector - (compile-list rhss rhs-env body-stack-depth stk-i #F))) + (compile-list rhss rhs-env body-stack-depth stk-i #f mutated))) + (define new-body (add-boxes/remove-unused c-body ids #hasheq() body-env stk-i)) (define pos (stack->pos stack-depth stk-i #:nonuse? #t)) (stack-info-forget! stk-i stack-depth pos count) (vector 'letrec pos new-rhss new-body)])) - (define (compile-apply es env stack-depth stk-i tail?) - (define new-es (compile-list es env stack-depth stk-i #f)) + (define (compile-apply es env stack-depth stk-i tail? mutated) (unless tail? (stack-info-non-tail! stk-i stack-depth)) + (define new-es (compile-list es env stack-depth stk-i #f mutated)) (list->vector (cons 'app new-es))) - (define (compile-assignment id rhs env stack-depth stk-i) - (define compiled-rhs (compile-expr rhs env stack-depth stk-i #f)) + (define (compile-assignment id rhs env stack-depth stk-i mutated) + (define compiled-rhs (compile-expr rhs env stack-depth stk-i #f mutated)) (define u (unwrap id)) (define var (hash-ref env u)) (cond @@ -403,42 +441,147 @@ (if (boxed/check? var) (vector 'set!-boxed/checked s compiled-rhs u) (vector 'set!-boxed s compiled-rhs u))] - [else (error 'compile "unexpected set!")])) + [else (error 'compile "unexpected set! ~s -> ~v" u var)])) - (define (args->env ids env stack-depth) + (define (extract-expr-mutated e mutated) + (match e + [`(lambda ,ids . ,body) + (extract-list-mutated body mutated)] + [`(case-lambda [,idss . ,bodys] ...) + (for/fold ([mutated mutated]) ([body (in-list bodys)]) + (extract-list-mutated body mutated))] + [`(let ([,ids ,rhss] ...) . ,body) + (extract-list-mutated body (extract-list-mutated rhss mutated))] + [`(letrec ([,ids ,rhss] ...) . ,body) + (extract-list-mutated body (extract-list-mutated rhss mutated))] + [`(letrec* ([,ids ,rhss] ...) . ,body) + (extract-list-mutated body (extract-list-mutated rhss mutated))] + [`(begin . ,vs) + (extract-list-mutated vs mutated)] + [`(begin0 ,vs) + (extract-list-mutated vs mutated)] + [`($value ,e) + (extract-expr-mutated e mutated)] + [`(if ,tst ,thn ,els) + (define tst-mutated (extract-expr-mutated tst mutated)) + (define thn-mutated (extract-expr-mutated thn tst-mutated)) + (extract-expr-mutated els thn-mutated)] + [`(with-continuation-mark* ,mode ,key ,val ,body) + (define key-mutated (extract-expr-mutated key mutated)) + (define val-mutated (extract-expr-mutated val key-mutated)) + (extract-expr-mutated body val-mutated)] + [`(quote ,v) + mutated] + [`(set! ,id ,rhs) + (define new-mutated (hash-set mutated (unwrap id) #t)) + (extract-expr-mutated rhs new-mutated)] + [`(define ,id ,rhs) + (extract-expr-mutated rhs mutated)] + [`(define-values ,ids ,rhs) + (extract-expr-mutated rhs mutated)] + [`(variable-set! ,dest-id ,e) + (extract-expr-mutated e mutated)] + [`(variable-set!/define ,dest-id ,e ',constance) + (extract-expr-mutated e mutated)] + [`(variable-ref ,id) + mutated] + [`(variable-ref/no-check ,id) + mutated] + [`(#%app ,es ...) + (extract-list-mutated es mutated)] + [`(,es ...) + (extract-list-mutated es mutated)] + [`,id + mutated])) + + (define (extract-list-mutated body mutated) + (let loop ([body body] [mutated mutated]) + (cond + [(null? body) mutated] + [else + (loop (wrap-cdr body) + (extract-expr-mutated (wrap-car body) mutated))]))) + + (define (args->env ids env stack-depth mutated) (let loop ([ids ids] [env env] [count 0]) (cond [(wrap-null? ids) (values env count #f)] [(wrap-pair? ids) (loop (wrap-cdr ids) - (hash-set env (unwrap (wrap-car ids)) (+ stack-depth count)) + (env-set env (unwrap (wrap-car ids)) (+ stack-depth count) mutated) (add1 count))] [else - (values (hash-set env (unwrap ids) (+ stack-depth count)) + (values (env-set env (unwrap ids) (+ stack-depth count) mutated) (add1 count) #t)]))) + (define (env-set env u pos mutated) + (hash-set env u (if (hash-ref mutated u #f) + (boxed pos) + pos))) + (define (add-clears e stk-i all-clear) - (define local-use-map (stack-info-local-use-map stk-i)) - (define clears - (for/list ([pos (in-hash-keys all-clear)] - #:unless (hash-ref local-use-map pos #f)) - pos)) (cond - [(null? clears) e] - [else (vector 'clear (sort clears <) e)])) + [(stack-info-branch-need-clears? stk-i) + (define local-use-map (stack-info-local-use-map stk-i)) + (define clears + (for/list ([pos (in-hash-keys all-clear)] + #:unless (hash-ref local-use-map pos #f)) + pos)) + (cond + [(null? clears) e] + [else (vector 'clear (sort clears <) e)])] + [else e])) + + (define (add-boxes/remove-unused e ids mutated env stk-i) + (cond + [(null? ids) e] + [(pair? ids) + (add-boxes/remove-unused (add-boxes/remove-unused e (car ids) mutated env stk-i) + (cdr ids) + mutated + env + stk-i)] + [else + (define u (unwrap ids)) + (define var (hash-ref env u #f)) + (define pos (stack->pos (if (boxed? var) (boxed-pos var) var) stk-i)) ; box result means unused + (cond + [(box? pos) + (vector 'clear (list (unbox pos)) e)] + [(not (hash-ref mutated u #f)) + e] + [else + (vector 'enbox pos e)])])) + + (define (extract-procedure-wrap-data e) + ;; Get name and method-arity information + (define encoded-name (wrap-property e 'inferred-name)) + (define name + (cond + [(eq? encoded-name '|[|) #f] + [(symbol? encoded-name) + (define s (symbol->immutable-string encoded-name)) + (cond + [(fx= 0 (string-length s)) encoded-name] + [else + (define ch (string-ref s 0)) + (cond + [(or (char=? #\[ ch) + (char=? #\] ch)) + (string->symbol (substring s 1 (string-length s)))] + [else encoded-name])])] + [else encoded-name])) + (if (wrap-property e 'method-arity-error) + (box name) + name)) (with-deterministic-gensym (start linklet-e))) ;; ---------------------------------------- -(define (interpret-linklet b ; compiled form - paths ; unmarshaled paths - primitives ; hash of symbol -> value - ;; the implementation of variables: - variable-ref variable-ref/no-check variable-set! variable-set!/define - ;; to create a procedure with a specific arity mask: - make-arity-wrapper-procedure) +(define (interpret-linklet b ; compiled form + paths) ; unmarshaled paths (interp-match b [#(,consts ,num-body-vars ,b) @@ -452,7 +595,7 @@ (vector-set! vec i (car paths)) (cdr paths)] [else - (vector-set! vec i (interpret-expr b stack primitives void void void void void)) + (vector-set! vec i (interpret-expr b stack)) paths])) vec))]) (lambda args @@ -465,98 +608,120 @@ (define post-args-pos (stack-count args-stack)) (define stack (for/fold ([stack args-stack]) ([i (in-range num-body-vars)]) (stack-set stack (+ i post-args-pos) (box unsafe-undefined)))) - (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! variable-set!/define - make-arity-wrapper-procedure)))])) + (interpret-expr b stack)))])) -(define (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! variable-set!/define - make-arity-wrapper-procedure) +(define (interpret-expr b stack) - ;; Returns `result ...` when `tail?` is #t, and - ;; returns `(values stack result ...)` when `tail?` is #f. - ;; An updated "stack" is returned because bindings are - ;; removed from the stack on their last uses (where there is - ;; a non-tail call after the last use) - (define (interpret b stack [tail? #f]) + ;; An updated "stack" must be returned when bindings are removed + ;; from the stack on their last uses (where there is a non-tail call + ;; after the last use). But that stack is not needed by a caller if + ;; we're in tail position with respect to the start of interpreting. + ;; That case is when `return-mode` is #f. Meanwhile, if we're in a + ;; `with-continuation-mark`, we need a little trampoline to make a + ;; call to an unknown function (that might use marks) while also + ;; keeping track of the latest stack; that case is when + ;; `return-mode` is a hash table, and returning 'trampoline + ;; for the stack triggers the trampoline to ship marks to be + ;; around the call within `values` to return the actual stack. + (define (interpret b stack [return-mode 'values]) (cond - [(integer? b) (stack-ref stack b tail?)] - [(box? b) (stack-ref stack b tail?)] + [(integer? b) (stack-ref stack b (not return-mode))] + [(box? b) (stack-ref stack b (not return-mode))] [(pair? b) (define-values (new-stack vec) (stack-ref stack (car b))) (define val (vector*-ref vec (cdr b))) - (if tail? - val - (values new-stack val))] + (if return-mode + (values new-stack val) + val)] [(symbol? b) (define val (hash-ref primitives b)) - (if tail? - val - (values stack val))] + (if return-mode + (values stack val) + val)] [(vector? b) (interp-match b [#(app ,rator-b) (define len (vector*-length b)) (define-values (rand-stack rator) (interpret rator-b stack)) - (define-syntax-rule (add-value stack app) - (call-with-values - (lambda () app) - (case-lambda - [(v) (values stack v)] - [vs (apply values stack vs)]))) + (define-syntax-rule (return-stack stack app) + (if (eq? return-mode 'values) + (call-with-values + (lambda () app) + (case-lambda + [(v) (values stack v)] + [vs (apply values stack vs)])) + (let ([marks return-mode]) + (values + 'trampoline + (lambda () + (call-with-values + (lambda () + (let loop ([i (hash-iterate-first marks)]) + (cond + [(not i) app] + [else + (define-values (k v) (hash-iterate-key+value marks i)) + (with-continuation-mark + k v + (loop (hash-iterate-next marks i)))]))) + (case-lambda + [(v) (values stack v)] + [vs (apply values stack vs)]))))))) (cond [(eq? len 2) - (if tail? - (rator) - (add-value stack (rator)))] + (if return-mode + (return-stack rand-stack (rator)) + (rator))] [(eq? len 3) (define-values (stack rand) (interpret (vector*-ref b 2) rand-stack)) - (if tail? - (rator rand) - (add-value stack (rator rand)))] + (if return-mode + (return-stack stack (rator rand)) + (rator rand))] [(eq? len 4) (define-values (stack1 rand1) (interpret (vector*-ref b 2) rand-stack)) (define-values (stack2 rand2) (interpret (vector*-ref b 3) stack1)) - (if tail? - (rator rand1 rand2) - (add-value stack (rator rand1 rand2)))] + (if return-mode + (return-stack stack2 (rator rand1 rand2)) + (rator rand1 rand2))] [else (define-values (stack rev-rands) (for/fold ([stack rand-stack] [rev-rands null]) ([b (in-vector b 2)]) (define-values (new-stack v) (interpret b stack)) (values new-stack (cons v rev-rands)))) (define rands (reverse rev-rands)) - (if tail? - (apply rator rands) - (add-value stack (apply rator rands)))])] + (if return-mode + (return-stack stack (apply rator rands)) + (apply rator rands))])] [#(quote ,v) - (if tail? - v - (values stack v))] + (if return-mode + (values stack v) + v)] [#(unbox ,s) (define-values (new-stack bx) (stack-ref stack s)) (define val (unbox* bx)) - (if tail? - val - (values new-stack val))] + (if return-mode + (values new-stack val) + val)] [#(unbox/checked ,s ,name) (define-values (new-stack bx) (stack-ref stack s)) (define v (unbox* bx)) (define val (check-not-unsafe-undefined v name)) - (if tail? - val - (values new-stack val))] + (if return-mode + (values new-stack val) + val)] [#(ref-variable ,s) (define-values (new-stack var) (stack-ref stack s)) (define val (variable-ref/no-check var)) - (if tail? - val - (values new-stack val))] + (if return-mode + (values new-stack val) + val)] [#(ref-variable/checked ,s) (define-values (new-stack var) (stack-ref stack s)) (define val (variable-ref var)) - (if tail? - val - (values new-stack val))] + (if return-mode + (values new-stack val) + val)] [#(let ,pos ,rhss ,b) (define len (vector*-length rhss)) (define body-stack @@ -566,7 +731,7 @@ [else (define-values (new-stack val) (interpret (vector*-ref rhss i) stack)) (stack-set (loop (fx+ i 1) new-stack) (fx+ i pos) val)]))) - (interpret b body-stack tail?)] + (interpret b body-stack return-mode)] [#(let* ,poss ,rhsss ,b) (define body-stack (for/fold ([stack stack]) ([pos (in-list poss)] @@ -577,19 +742,25 @@ [(fx= i len) stack] [else (define-values (new-stack val) (interpret (vector*-ref rhss i) stack)) - (stack-set (loop (fx+ i 1) new-stack) (fx+ i pos) val)])))) - (interpret b body-stack tail?)] + (loop (fx+ i 1) (stack-set new-stack (fx+ i pos) val))])))) + (interpret b body-stack return-mode)] [#(letrec ,pos ,rhss ,b) (define len (vector*-length rhss)) (define-values (body-stack boxes) - (for/fold ([stack stack] [boxes null]) ([i (in-range len)]) - (define bx (box unsafe-undefined)) - (values (stack-set stack (fx+ (fx- len i 1) pos) bx) - (cons bx boxes)))) + (let loop ([stack stack] [i 0]) + (cond + [(= i len) + (values stack null)] + [else + (define bx (box unsafe-undefined)) + (define-values (new-stack boxes) + (loop (stack-set stack (fx+ (fx- len i 1) pos) bx) + (add1 i))) + (values new-stack (cons bx boxes))]))) (let loop ([i 0] [stack body-stack] [boxes boxes]) (cond [(fx= i len) - (interpret b stack tail?)] + (interpret b stack return-mode)] [else (define-values (new-stack val) (interpret (vector*-ref rhss i) stack)) (set-box! (car boxes) val) @@ -599,7 +770,7 @@ (let loop ([i 1] [stack stack]) (cond [(fx= i last) - (interpret (vector*-ref b i) stack tail?)] + (interpret (vector*-ref b i) stack return-mode)] [else (call-with-values (lambda () (interpret (vector*-ref b i) stack)) @@ -619,34 +790,63 @@ [(new-stack val) new-stack] [(new-stack . vals) new-stack]))) (if (fx= i last) - (if tail? - (apply values vals) - (apply values new-stack vals)) + (if return-mode + (apply values new-stack vals) + (apply values vals)) (loop (fx+ i 1) new-stack)))))] [#($value ,e) - (let-values ([(new-stack v) (interpret e stack #f)]) - (if tail? - v - (values new-stack v)))] + (let-values ([(new-stack v) (interpret e stack)]) + (if return-mode + (values new-stack v) + v))] [#(clear ,clears ,e) (let loop ([clears clears] [stack stack]) (cond [(null? clears) - (interpret e stack tail?)] + (interpret e stack return-mode)] [else (loop (cdr clears) (stack-remove stack (car clears)))]))] + [#(enbox ,pos ,e) + (define new-stack (stack-set stack pos (box (stack-ref stack pos #t)))) + (interpret e new-stack return-mode)] [#(if ,tst ,thn ,els) (define-values (new-stack val) (interpret tst stack)) (if val - (interpret thn new-stack tail?) - (interpret els new-stack tail?))] + (interpret thn new-stack return-mode) + (interpret els new-stack return-mode))] [#(wcm ,key ,val ,body) (define-values (k-stack k-val) (interpret key stack)) (define-values (v-stack v-val) (interpret val k-stack)) - (with-continuation-mark - k-val - v-val - (interpret body v-stack tail?))] + (cond + [(not return-mode) + ;; In tail position, so we can just use + ;; with-continuation-mark` directly: + (with-continuation-mark + k-val + v-val + (interpret body v-stack #f))] + [(eq? return-mode 'values) + ;; Not in tail position with respect to a `with-continuation-mark`. + ;; Build a trampoline so that we can get an updated stack, but a function + ;; can be called in tail position with respect to marks + ((call-with-values + (lambda () + (with-continuation-mark + k-val v-val + (interpret body v-stack (hasheq k-val v-val)))) + (case-lambda + [(stack v) (if (eq? stack 'trampoline) + ;; trampoline return: + v + ;; normal return: + (lambda () (values stack v)))] + [(stack . vs) (lambda () (apply values stack vs))])))] + [else + ;; In tail position with respect to a `with-continuation-mark`, + ;; so take advantage of its `return-mode` trampoline: + (with-continuation-mark + k-val v-val + (interpret body v-stack (hash-set return-mode k-val v-val)))])] [#(cwv ,b ,pos ,name ,clauses) (define-values (new-stack vs) (call-with-values @@ -655,42 +855,38 @@ (define len (length vs)) (let loop ([clauses clauses] [full-mask 0]) (cond - [(null? clauses)(apply raise-arity-mask-error (or name '|#|) full-mask vs)] + [(null? clauses) (apply raise-arity-mask-error (or name '|#|) full-mask vs)] [else (interp-match (car clauses) [#(,mask ,b) (if (matching-argument-count? mask len) - (interpret b (push-stack new-stack pos vs mask) tail?) + (interpret b (push-stack new-stack pos vs mask) return-mode) (loop (cdr clauses) (fxior mask full-mask)))])]))] [#(cwmp0 ,b) - (unless tail? (error 'interpret "expect call-with-module-prompt in tail position")) + (when return-mode (error 'interpret "expect call-with-module-prompt in tail position")) ((hash-ref primitives 'call-with-module-prompt) - (lambda () (interpret b stack #t)))] + (lambda () (interpret b stack #f)))] [#(cwmp ,b ,ids ,constances ,var-es) - (unless tail? (error 'interpret "expect call-with-module-prompt in tail position")) + (when return-mode (error 'interpret "expect call-with-module-prompt in tail position")) (apply (hash-ref primitives 'call-with-module-prompt) - (lambda () (interpret b stack #t)) + (lambda () (interpret b stack #f)) ids constances (for/list ([e (in-list var-es)]) - (interpret e stack #t)))] - [#(lambda ,mask ,name ,close-vec ,_) + (interpret e stack #f)))] + [#(lambda ,mask ,wrap-data ,close-vec ,_) (define-values (new-stack captured) (capture-closure close-vec stack)) (define val - (make-arity-wrapper-procedure + (make-interp-procedure* (lambda args - (cond - [(matching-argument-count? mask (length args)) - (apply-function b captured args)] - [else - (apply raise-arity-mask-error (or name '|#|) mask args)])) + (apply-function b captured args)) mask - name)) - (if tail? - val - (values new-stack val))] - [#(case-lambda ,mask ,name) + wrap-data)) + (if return-mode + (values new-stack val) + val)] + [#(case-lambda ,mask ,wrap-data) (define n (vector*-length b)) (define-values (new-stack captureds) (let loop ([i 3] [stack stack]) @@ -701,16 +897,18 @@ (define-values (new-stack captured) (interp-match (vector*-ref b i) - [#(lambda ,mask ,name ,close-vec) (capture-closure close-vec rest-stack)])) + [#(lambda ,mask ,_ ,close-vec) (capture-closure close-vec rest-stack)])) (values new-stack (cons captured rest-captureds))]))) (define val - (make-arity-wrapper-procedure + (make-interp-procedure* (lambda args (define len (length args)) (let loop ([i 3] [captureds captureds] [full-mask 0]) (cond [(fx= i n) - (apply raise-arity-mask-error (or name '|#|) full-mask args)] + ;; We shouldn't get here, because the wrapper shoudl enforce arity, + ;; but just in case: + (apply raise-arity-mask-error '|#| full-mask args)] [else (define one-b (vector*-ref b i)) (interp-match @@ -720,44 +918,44 @@ (apply-function one-b (car captureds) args) (loop (fx+ i 1) (cdr captureds) (fxior full-mask mask)))])]))) mask - #f)) - (if tail? - val - (values new-stack val))] + wrap-data)) + (if return-mode + (values new-stack val) + val)] [#(set-variable! ,s ,b ,c ,defn?) (define-values (var-stack var) (stack-ref stack s)) (define-values (val-stack val) (interpret b var-stack)) (if defn? (variable-set!/define var val c) (variable-set! var val)) - (if tail? - (void) - (values val-stack (void)))] + (if return-mode + (values val-stack (void)) + (void))] [#(set!-indirect ,s ,e ,b) (define-values (vec-stack vec) (stack-ref stack s)) (define-values (val-stack val) (interpret b vec-stack)) (vector*-set! vec e val) - (if tail? - (void) - (values val-stack (void)))] + (if return-mode + (values val-stack (void)) + (void))] [#(set!-boxed ,s ,b ,name) (define-values (bx-stack bx) (stack-ref stack s)) (define-values (v-stack v) (interpret b bx-stack)) (set-box*! bx v) - (if tail? - (void) - (values v-stack (void)))] + (if return-mode + (values v-stack (void)) + (void))] [#(set!-boxed/checked ,s ,b ,name) (define-values (bx-stack bx) (stack-ref stack s)) (define-values (v-stack v) (interpret b bx-stack)) (check-not-unsafe-undefined/assign (unbox* bx) name) (set-box*! bx v) - (if tail? - (void) - (values v-stack (void)))])] - [else (if tail? - b - (values stack b))])) + (if return-mode + (values v-stack (void)) + (void))])] + [else (if return-mode + (values stack b) + b)])) (define (capture-closure close-vec stack) (define len (vector*-length close-vec)) @@ -774,7 +972,7 @@ (interp-match b [#(lambda ,mask ,name ,close-vec ,b) - (interpret b (push-stack captured 0 args mask) #t)])) + (interpret b (push-stack captured 0 args mask) #f)])) (cond [(vector? b) @@ -786,14 +984,14 @@ (define e (vector*-ref b i)) (cond [(= i last) - (interpret e stack #t)] + (interpret e stack #f)] [else - (interpret e stack #t) + (interpret e stack #f) (loop (add1 i))]))] [#() - (interpret b stack #t)])] + (interpret b stack #f)])] [else - (interpret b stack #t)])) + (interpret b stack #f)])) ;; ---------------------------------------- @@ -813,8 +1011,17 @@ 'vector vector 'add1 add1 'values values - 'continuation-mark-set-first continuation-mark-set-first)) + 'continuation-mark-set-first continuation-mark-set-first + 'gensym gensym + 'apply apply + 'make-weak-box make-weak-box + 'void void)) (struct var ([val #:mutable]) #:transparent) + (interpreter-link! primitives + values + var-val var-val + (lambda (b v) (set-var-val! b v)) (lambda (b v c) (set-var-val! b v)) + (lambda (proc mask name) proc)) (define b (interpretable-jitified-linklet '(let* ([s "string"]) (lambda (x two-box) @@ -852,9 +1059,7 @@ (f 'vec) (g 'also-vec 'more) one two (variable-ref two-box) (continuation-mark-set-first #f 'x 'no)))))) - values)) + #f)) (pretty-print b) - (define l (interpret-linklet b null primitives var-val var-val - (lambda (b v) (set-var-val! b v)) (lambda (b v c) (set-var-val! b v)) - (lambda (proc mask name) proc))) + (define l (interpret-linklet b null)) (l 'the-x (var #f))) diff --git a/racket/src/schemify/intmap.rkt b/racket/src/schemify/intmap.rkt index aab5ecb7d3..de7d100b8a 100644 --- a/racket/src/schemify/intmap.rkt +++ b/racket/src/schemify/intmap.rkt @@ -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 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) - (fxand (fxior h (fx- m 1)) (fxnot m))) +(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 (branching-bit p m) - (highest-set-bit (fxxor p m))) + ;; 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))) -(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 (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-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)))) + ;; 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))) + + ;; 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 (br p m l r) - (let ([c (fx+ (intmap-count l) (intmap-count r))]) - (Br c p m l r))) +(define-rotate rotate-right node-left node-right combine) +(define-rotate rotate-left node-right node-left reverse-combine) -(define (br/check-left p m l r) - (if l - (br p m l r) - r)) +;; ---------------------------------------- -(define (br/check-right p m l r) - (if r - (br p m l r) - l)) +(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") diff --git a/racket/src/schemify/main.rkt b/racket/src/schemify/main.rkt index 03497d0e89..9bb5921194 100644 --- a/racket/src/schemify/main.rkt +++ b/racket/src/schemify/main.rkt @@ -25,6 +25,7 @@ make-path->compiled-path compiled-path->path + interpreter-link! interpretable-jitified-linklet interpret-linklet diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index d97b9d1beb..7d24473c4c 100644 --- a/racket/src/schemify/schemify.rkt +++ b/racket/src/schemify/schemify.rkt @@ -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))