From 68e105c0edffba343ce2db15795affae1b1b3073 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 30 Nov 2018 10:38:55 -0700 Subject: [PATCH] cs: prompts for module-body expressions Module definitions and expression need to have a prompt around them to delimit continuation capture, variable assignment needs to happen at the right point to ensure that reassignment is guarded and non-assignment is detected. But avoid the prompt when it's not needed, such as around function definitions. Closes #2398 --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/linklet.scrbl | 55 +++- .../racket-test-core/tests/racket/module.rktl | 24 ++ racket/src/cs/convert.rkt | 2 +- racket/src/cs/linklet.sls | 142 ++++++++- racket/src/cs/primitive/internal.ss | 2 + racket/src/cs/primitive/kernel.ss | 80 ++--- racket/src/cs/primitive/linklet.ss | 7 +- racket/src/cs/primitive/unsafe.ss | 176 +++++------ racket/src/cs/schemify.sls | 2 + racket/src/expander/compile/form.rkt | 11 +- racket/src/expander/compile/instance.rkt | 6 + racket/src/expander/compile/module.rkt | 1 + racket/src/expander/compile/recompile.rkt | 1 + racket/src/expander/expand/main.rkt | 16 +- racket/src/expander/run/linklet-operation.rkt | 1 + racket/src/expander/run/linklet.rkt | 3 + racket/src/racket/src/cify-startup.rkt | 2 + racket/src/racket/src/linklet.c | 22 +- racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/startup.inc | 293 ++++++++++-------- racket/src/schemify/find-definition.rkt | 18 ++ racket/src/schemify/known.rkt | 10 +- racket/src/schemify/schemify.rkt | 198 +++++++++--- racket/src/schemify/simple.rkt | 11 +- 26 files changed, 734 insertions(+), 357 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 2ef83ae057..1a380c4663 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.1.0.7") +(define version "7.1.0.8") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/linklet.scrbl b/pkgs/racket-doc/scribblings/reference/linklet.scrbl index 597ff07478..11dd738a12 100644 --- a/pkgs/racket-doc/scribblings/reference/linklet.scrbl +++ b/pkgs/racket-doc/scribblings/reference/linklet.scrbl @@ -120,7 +120,8 @@ otherwise.} [name any/c #f] [import-keys #f #f] [get-import #f #f] - [options (listof (or/c 'serializable 'unsafe 'static)) '(serializable)]) + [options (listof (or/c 'serializable 'unsafe 'static 'no-prompt)) + '(serializable)]) linklet?] [(compile-linklet [form (or/c correlated? any/c)] [name any/c] @@ -128,7 +129,8 @@ 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)) '(serializable)]) + [options (listof (or/c 'serializable 'unsafe 'static 'no-prompt)) + '(serializable)]) (values linklet? vector?)])]{ Takes an S-expression or @tech{correlated object} for a @@ -190,8 +192,14 @@ 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['no-prompt] is included in @racket[options], then when the +resulting linklet is instantiated, the @racket[_use-prompt?] argument +to @racket[instantiate-linklet] may be treated as @racket[#f]. + 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['no-prompt] option.}]} @defproc*[([(recompile-linklet [linklet linklet?] @@ -200,7 +208,8 @@ The symbols in @racket[options] must be distinct, otherwise [get-import (any/c . -> . (values (or/c linklet? #f) (or/c vector? #f))) (lambda (import-key) (values #f #f))] - [options (listof (or/c 'serializable 'unsafe 'static)) '(serializable)]) + [options (listof (or/c 'serializable 'unsafe 'static 'no-prompt)) + '(serializable)]) linklet?] [(recompile-linklet [linklet linklet?] [name any/c] @@ -208,13 +217,15 @@ The symbols in @racket[options] must be distinct, otherwise [get-import (any/c . -> . (values (or/c linklet? #f) (or/c vector? #f))) (lambda (import-key) (values #f #f))] - [options (listof (or/c 'serializable 'unsafe 'static)) '(serializable)]) + [options (listof (or/c 'serializable 'unsafe 'static 'no-prompt)) + '(serializable)]) (values linklet? vector?)])]{ Like @racket[compile-linklet], but takes an already-compiled linklet 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['no-prompt] option.}]} @defproc[(eval-linklet [linklet linklet?]) linklet?]{ @@ -416,6 +427,38 @@ variable. If a variable for @racket[name] exists as constant, the @exnraise[exn:fail:contract].} +@defproc[(instance-describe-variable! [instance instance?] + [name symbol?] + [desc-v any/c]) + void?]{ + +Registers information about @racket[name] in @racket[instance] that +may be useful for compiling linklets where the instance is return via +the @racket[_get-import] callback to @racket[compile-linklet]. The +@racket[desc-v] description can be any value; the recognized +descriptions depend on virtual machine, but may include the following: + +@itemlist[ + + @item{@racket[`(procedure ,arity-mask)] --- the value is always a + procedure that is not impersonated and not a structure, and its + arity in the style of @racket[procedure-arity-mask] is + @racket[arity-mask].} + + @item{@racket[`(procedure/succeeds ,arity-mask)] --- like + @racket[`(procedure ,arity-mask)], but for a procedure that + never raises an exception of otherwise captures or escapes the + calling context.} + + @item{@racket[`(procedure/pure ,arity-mask)] --- like + @racket[`(procedure/succeeds ,arity-mask)], but with no + observable side effects, so a call to the procedure can be + reordered.} + +] + +@history[#:added "7.1.0.8"]} + @defproc[(variable-reference->instance [varref variable-reference?] [ref-site? any/c #f]) (if ref-site? (or/c instance? #f symbol?) instance?)]{ diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index 07231614b9..c4fcf096be 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -1256,6 +1256,30 @@ (set! c (compile m)))))) (write c (open-output-bytes))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that the prompt around a module definitions works and allows +;; assignment to an otherwise mutable variable: + +(module assigns-to-variable-through-a-continuation racket/base + (provide result) + (define x (let/cc k k)) + (set! x x) + (x 5) + (define result x)) + +(test 5 dynamic-require ''assigns-to-variable-through-a-continuation 'result) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that the prompt around a module definitions does not allow +;; assignment to an otherwise constant binding. + +(module tries-to-assign-to-variable-through-a-continuation racket/base + (define x (let/cc k k)) + (x 5)) + +(err/rt-test (dynamic-require ''tries-to-assign-to-variable-through-a-continuation #f) + exn:fail:contract:variable?) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check that skipping definitions (but continuing ;; with the rest of a module body) is disallowed. diff --git a/racket/src/cs/convert.rkt b/racket/src/cs/convert.rkt index 3df7c2f9bf..bfff517f58 100644 --- a/racket/src/cs/convert.rkt +++ b/racket/src/cs/convert.rkt @@ -124,7 +124,7 @@ (printf "Schemify...\n") (define body (time - (schemify-body bodys/constants-lifted prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode?))) + (schemify-body bodys/constants-lifted prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode? #t))) (printf "Lift...\n") ;; Lift functions to aviod closure creation: (define lifted-body diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 69e2f8fce0..e101282ad3 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -18,6 +18,7 @@ instance-variable-value instance-set-variable-value! instance-unset-variable! + instance-describe-variable! linklet-virtual-machine-bytes write-linklet-bundle-hash @@ -48,6 +49,7 @@ install-linklet-primitive-tables! ; not exported to racket ;; schemify glue: + make-internal-variable variable-set! variable-set!/check-undefined variable-ref @@ -55,7 +57,8 @@ make-instance-variable-reference jitified-extract-closed jitified-extract - schemify-table) + schemify-table + call-with-module-prompt) (import (chezpart) (only (chezscheme) printf) (rumble) @@ -407,6 +410,7 @@ [(c name import-keys get-import) (compile-linklet c name import-keys get-import '(serializable))] [(c name import-keys get-import options) (define serializable? (#%memq 'serializable options)) + (define use-prompt? (#%memq 'use-prompt options)) (performance-region 'schemify (define jitify-mode? @@ -422,6 +426,7 @@ jitify-mode? (|#%app| compile-allow-set!-undefined) #f ;; safe mode + (not use-prompt?) prim-knowns ;; Callback to get a specific linklet for a ;; given import: @@ -593,21 +598,39 @@ constance ; #f (mutable), 'constant, or 'consistent (always the same shape) inst-box)) ; weak pair with instance in `car` - (define (variable-set! var val constance) + (define (make-internal-variable name) + (make-variable unsafe-undefined name #f (cons #!bwp #f))) + + (define (do-variable-set! var val constance as-define?) (cond [(variable-constance var) - (raise - (|#%app| - exn:fail:contract:variable - (string-append (symbol->string (variable-name var)) - ": cannot modify constant") - (current-continuation-marks) - (variable-name var)))] + (cond + [as-define? + (raise + (|#%app| + exn:fail:contract:variable + (string-append "define-values: assignment disallowed;\n" + " cannot re-define a constant\n" + " constant: " (symbol->string (variable-name var)) "\n" + " in module:" (variable-module-name var)) + (current-continuation-marks) + (variable-name var)))] + [else + (raise + (|#%app| + exn:fail:contract:variable + (string-append (symbol->string (variable-name var)) + ": cannot modify constant") + (current-continuation-marks) + (variable-name var)))])] [else (set-variable-val! var val) (when constance (set-variable-constance! var constance))])) + (define (variable-set! var val constance) + (do-variable-set! var val constance #f)) + (define (variable-set!/check-undefined var val constance) (when (eq? (variable-val var) unsafe-undefined) (raise-undefined var #t)) @@ -686,13 +709,46 @@ syms))) (define (variable->known var) - (let ([constance (variable-constance var)]) + (let ([desc (cdr (variable-inst-box var))]) (cond - [(not constance) #f] - [(and (eq? constance 'consistent) - (#%procedure? (variable-val var))) - (known-procedure (#%procedure-arity-mask (variable-val var)))] - [else a-known-constant]))) + [(and (pair? desc) (or (#%memq (car desc) '(procedure + procedure/succeeds + procedure/pure))) + (pair? (cdr desc)) (exact-integer? (cadr desc))) + (case (car desc) + [(procedure/pure) (known-procedure/pure (cadr desc))] + [(procedure/succeeds) (known-procedure/succeeds (cadr desc))] + [else (known-procedure (cadr desc))])] + [else + (let ([constance (variable-constance var)]) + (cond + [(not constance) #f] + [(and (eq? constance 'consistent) + (#%procedure? (variable-val var))) + (known-procedure (#%procedure-arity-mask (variable-val var)))] + [else a-known-constant]))]))) + + (define (check-variable-set var sym) + (when (eq? (variable-val var) unsafe-undefined) + (raise + (|#%app| + exn:fail:contract:variable + (string-append "define-values: skipped variable definition;\n" + " cannot continue without defining variable\n" + " variable: " (symbol->string sym) "\n" + " in module: " (variable-module-name var)) + (current-continuation-marks) + (variable-name var))))) + + (define (variable-describe! var desc) + (set-variable-inst-box! var (weak-cons (car (variable-inst-box var)) + desc))) + + (define (variable-module-name var) + (let ([i (car (variable-inst-box var))]) + (if (eq? i #!bwp) + "[unknown]" + (format "~a" (instance-name i))))) ;; ---------------------------------------- @@ -702,6 +758,10 @@ data hash)) ; symbol -> variable + (define-record-type data-with-describes + (fields data + describes)) + (define make-instance (case-lambda [(name) (make-instance name #f)] @@ -765,6 +825,15 @@ (when var (set-variable-val! var unsafe-undefined)))) + (define (instance-describe-variable! i k desc) + (unless (instance? i) + (raise-argument-error 'instance-describe-variable! "instance?" i)) + (unless (symbol? k) + (raise-argument-error 'instance-describe-variable! "symbol?" k)) + (let ([var (hash-ref (instance-hash i) k #f)]) + (when var + (variable-describe! var desc)))) + (define (check-constance who mode) (unless (or (not mode) (eq? mode 'constant) (eq? mode 'consistent)) (raise-argument-error who "(or/c #f 'constant 'consistant)" mode))) @@ -813,6 +882,49 @@ (make-variable-reference (variable-reference-instance vr) v)) ;; -------------------------------------------------- + + (define module-prompt-handler + (lambda (arg) + (abort-current-continuation + (default-continuation-prompt-tag) + arg))) + + (define call-with-module-prompt + (case-lambda + [(proc) + ;; No bindings to set or check, so just call `proc` in a prompt + (call-with-continuation-prompt + proc + (default-continuation-prompt-tag) + module-prompt-handler)] + [(proc syms modes var) + ;; Common case: one binding to set/check + (call-with-continuation-prompt + (lambda () + (do-variable-set! var (proc) (car modes) #t)) + (default-continuation-prompt-tag) + module-prompt-handler) + (check-variable-set var (car syms))] + [(proc syms modes . vars) + ;; General case: many bindings to set/check + (call-with-continuation-prompt + (lambda () + (call-with-values proc + (lambda vals + (unless (= (length syms) (length vals)) + (raise-binding-result-arity-error syms vals)) + (let loop ([vars vars] [vals vals] [modes modes]) + (unless (null? vars) + (do-variable-set! (car vars) (car vals) (car modes) #t) + (loop (cdr vars) (cdr vals) (cdr modes))))))) + (default-continuation-prompt-tag) + module-prompt-handler) + (let loop ([vars vars] [syms syms]) + (unless (null? vars) + (check-variable-set (car vars) (car syms)) + (loop (cdr vars) (cdr syms))))])) + + ;; -------------------------------------------------- (define compile-enforce-module-constants (make-parameter #t (lambda (v) (and v #t)))) diff --git a/racket/src/cs/primitive/internal.ss b/racket/src/cs/primitive/internal.ss index 0243e6efbf..7d8db5b2e6 100644 --- a/racket/src/cs/primitive/internal.ss +++ b/racket/src/cs/primitive/internal.ss @@ -29,6 +29,8 @@ [record-mutator (known-constant)] [unsafe-struct? (known-constant)] + [call-with-module-prompt (known-procedure 2)] + [fork-place (known-procedure 1)] [start-place (known-procedure 32)] [make-pthread-parameter (known-procedure 2)]) diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index 465c4d3d46..e82d4a7729 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -27,7 +27,7 @@ [arithmetic-shift (known-procedure 4)] [arity-at-least (known-constant)] [arity-at-least-value (known-procedure 2)] - [arity-at-least? (known-procedure/succeeds 2)] + [arity-at-least? (known-procedure/pure 2)] [asin (known-procedure 2)] [assoc (known-procedure 4)] [assq (known-procedure 4)] @@ -40,12 +40,12 @@ [bitwise-ior (known-procedure -1)] [bitwise-not (known-procedure 2)] [bitwise-xor (known-procedure -1)] - [boolean? (known-procedure/succeeds 2)] + [boolean? (known-procedure/pure 2)] [bound-identifier=? (known-procedure 28)] - [box (known-procedure/succeeds 2)] + [box (known-procedure/pure 2)] [box-cas! (known-procedure 8)] [box-immutable (known-procedure 2)] - [box? (known-procedure/succeeds 2)] + [box? (known-procedure/pure 2)] [break-enabled (known-procedure 3)] [break-thread (known-procedure 6)] [build-path (known-procedure -2)] @@ -55,7 +55,7 @@ [byte-ready? (known-procedure 3)] [byte-regexp (known-procedure 6)] [byte-regexp? (known-procedure 2)] - [byte? (known-procedure/succeeds 2)] + [byte? (known-procedure/pure 2)] [bytes (known-procedure -1)] [bytes->immutable-bytes (known-procedure 2)] [bytes->list (known-procedure 2)] @@ -82,7 +82,7 @@ [bytes? (known-procedure -2)] - [bytes? (known-procedure/succeeds 2)] + [bytes? (known-procedure/pure 2)] [caaaar (known-procedure 2)] [caaadr (known-procedure 2)] [caaar (known-procedure 2)] @@ -143,7 +143,7 @@ [chaperone-struct-type (known-procedure -16)] [chaperone-vector (known-procedure -8)] [chaperone-vector* (known-procedure -8)] - [chaperone? (known-procedure/succeeds 2)] + [chaperone? (known-procedure/pure 2)] [char->integer (known-procedure 2)] [char-alphabetic? (known-procedure 2)] [char-blank? (known-procedure 2)] @@ -173,7 +173,7 @@ [char=? (known-procedure -2)] [char>=? (known-procedure -2)] [char>? (known-procedure -2)] - [char? (known-procedure/succeeds 2)] + [char? (known-procedure/pure 2)] [checked-procedure-check-and-extract (known-procedure 32)] [choice-evt (known-procedure -1)] [cleanse-path (known-procedure 2)] @@ -186,8 +186,8 @@ [compile-enforce-module-constants (known-constant)] [compile-target-machine? (known-procedure 2)] [complete-path? (known-procedure 2)] - [complex? (known-procedure/succeeds 2)] - [cons (known-procedure/succeeds 4)] + [complex? (known-procedure/pure 2)] + [cons (known-procedure/pure 4)] [continuation-mark-key? (known-procedure 2)] [continuation-mark-set->context (known-procedure 2)] [continuation-mark-set->list (known-procedure 12)] @@ -266,10 +266,10 @@ [date-week-day (known-procedure 2)] [date-year (known-procedure 2)] [date-year-day (known-procedure 2)] - [date? (known-procedure/succeeds 2)] + [date? (known-procedure/pure 2)] [datum->syntax (known-procedure 60)] [datum-intern-literal (known-procedure 2)] - [default-continuation-prompt-tag (known-procedure/succeeds 1)] + [default-continuation-prompt-tag (known-procedure/pure 1)] [delete-directory (known-procedure 2)] [delete-file (known-procedure 2)] [denominator (known-procedure 2)] @@ -285,18 +285,18 @@ [environment-variables-set! (known-procedure 24)] [environment-variables? (known-procedure 2)] [eof (known-constant)] - [eof-object? (known-procedure/succeeds 2)] + [eof-object? (known-procedure/pure 2)] [ephemeron-value (known-procedure 6)] - [ephemeron? (known-procedure/succeeds 2)] + [ephemeron? (known-procedure/pure 2)] [eprintf (known-procedure -2)] [eq-hash-code (known-procedure 2)] - [eq? (known-procedure/succeeds 4)] + [eq? (known-procedure/pure 4)] [equal-hash-code (known-procedure 2)] [equal-secondary-hash-code (known-procedure 2)] [equal? (known-procedure 4)] [equal?/recur (known-procedure 8)] [eqv-hash-code (known-procedure 2)] - [eqv? (known-procedure/succeeds 4)] + [eqv? (known-procedure/pure 4)] [error (known-procedure -2)] [error-display-handler (known-constant)] [error-escape-handler (known-constant)] @@ -308,9 +308,9 @@ [even? (known-procedure 2)] [evt? (known-procedure 2)] [exact->inexact (known-procedure 2)] - [exact-integer? (known-procedure/succeeds 2)] + [exact-integer? (known-procedure/pure 2)] [exact-nonnegative-integer? (known-procedure 2)] - [exact-positive-integer? (known-procedure/succeeds 2)] + [exact-positive-integer? (known-procedure/pure 2)] [exact? (known-procedure 2)] [executable-yield-handler (known-constant)] [exit (known-procedure 3)] @@ -392,9 +392,9 @@ [filesystem-change-evt? (known-procedure 2)] [filesystem-root-list (known-procedure 1)] [find-system-path (known-procedure 2)] - [fixnum? (known-procedure/succeeds 2)] + [fixnum? (known-procedure/pure 2)] [floating-point-bytes->real (known-procedure 30)] - [flonum? (known-procedure/succeeds 2)] + [flonum? (known-procedure/pure 2)] [floor (known-procedure 2)] [flush-output (known-procedure 3)] [for-each (known-procedure -4)] @@ -431,11 +431,11 @@ [hash-set (known-procedure 8)] [hash-set! (known-procedure 8)] [hash-weak? (known-procedure 2)] - [hash? (known-procedure/succeeds 2)] + [hash? (known-procedure/pure 2)] [hasheq (known-procedure -1)] [hasheqv (known-procedure -1)] [imag-part (known-procedure 2)] - [immutable? (known-procedure/succeeds 2)] + [immutable? (known-procedure/pure 2)] [impersonate-box (known-procedure -8)] [impersonate-channel (known-procedure -8)] [impersonate-continuation-mark-key (known-procedure -8)] @@ -451,7 +451,7 @@ [impersonator-prop:application-mark (known-constant)] [impersonator-property-accessor-procedure? (known-procedure 2)] [impersonator-property? (known-procedure 2)] - [impersonator? (known-procedure/succeeds 2)] + [impersonator? (known-procedure/pure 2)] [inexact->exact (known-procedure 2)] [inexact-real? (known-procedure 2)] [inexact? (known-procedure 2)] @@ -473,8 +473,8 @@ [lcm (known-procedure -1)] [length (known-procedure 2)] [link-exists? (known-procedure 2)] - [list (known-procedure/succeeds -1)] - [list* (known-procedure/succeeds -2)] + [list (known-procedure/pure -1)] + [list* (known-procedure/pure -2)] [list->bytes (known-procedure 2)] [list->string (known-procedure 2)] [list->vector (known-procedure 2)] @@ -542,7 +542,7 @@ [make-struct-field-mutator (known-procedure 12)] [make-struct-type (known-procedure 4080)] [make-struct-type-property (known-procedure 30)] - [make-thread-cell (known-procedure 6)] + [make-thread-cell (known-procedure/pure 6)] [make-thread-group (known-procedure 3)] [make-vector (known-procedure 6)] [make-weak-box (known-procedure 2)] @@ -554,19 +554,19 @@ [max (known-procedure -2)] [mcar (known-procedure 2)] [mcdr (known-procedure 2)] - [mcons (known-procedure/succeeds 4)] + [mcons (known-procedure/pure 4)] [min (known-procedure -2)] [modulo (known-procedure 4)] - [mpair? (known-procedure/succeeds 2)] + [mpair? (known-procedure/pure 2)] [nack-guard-evt (known-procedure 2)] [negative? (known-procedure 2)] [never-evt (known-constant)] [newline (known-procedure 3)] [not (known-procedure 2)] [null (known-literal '(quote ()))] - [null? (known-procedure/succeeds 2)] + [null? (known-procedure/pure 2)] [number->string (known-procedure 6)] - [number? (known-procedure/succeeds 2)] + [number? (known-procedure/pure 2)] [numerator (known-procedure 2)] [object-name (known-procedure 2)] [odd? (known-procedure 2)] @@ -579,7 +579,7 @@ [open-output-string (known-procedure 3)] [ormap (known-procedure -4)] [output-port? (known-procedure 2)] - [pair? (known-procedure/succeeds 2)] + [pair? (known-procedure/pure 2)] [parameter-procedure=? (known-procedure 4)] [parameter? (known-procedure 2)] [parameterization? (known-procedure 2)] @@ -670,7 +670,7 @@ [procedure-result-arity (known-procedure 2)] [procedure-specialize (known-procedure 2)] [procedure-struct-type? (known-procedure 2)] - [procedure? (known-procedure/succeeds 2)] + [procedure? (known-procedure/pure 2)] [progress-evt? (known-procedure 6)] [prop:arity-string (known-constant)] [prop:authentic (known-struct-type-property/immediate-guard)] @@ -832,7 +832,7 @@ [string=? (known-procedure -2)] [string>=? (known-procedure -2)] [string>? (known-procedure -2)] - [string? (known-procedure/succeeds 2)] + [string? (known-procedure/pure 2)] [struct->vector (known-procedure 6)] [struct-accessor-procedure? (known-procedure 2)] [struct-constructor-procedure? (known-procedure 2)] @@ -887,7 +887,7 @@ [symbol-interned? (known-procedure 2)] [symbol-unreadable? (known-procedure 2)] [symbolimmutable-vector (known-procedure 2)] [vector->list (known-procedure 2)] [vector->pseudo-random-generator (known-procedure 2)] @@ -956,13 +956,13 @@ [vector-ref (known-procedure 4)] [vector-set! (known-procedure 8)] [vector-set-performance-stats! (known-procedure 6)] - [vector? (known-procedure/succeeds 2)] + [vector? (known-procedure/pure 2)] [vector*-length (known-procedure 2)] [vector*-ref (known-procedure 4)] [vector*-set! (known-procedure 8)] - [version (known-procedure 1)] - [void (known-procedure/succeeds -1)] - [void? (known-procedure/succeeds 2)] + [version (known-procedure/pure 1)] + [void (known-procedure/pure -1)] + [void? (known-procedure/pure 2)] [weak-box-value (known-procedure 6)] [weak-box? (known-procedure 2)] [will-execute (known-procedure 2)] diff --git a/racket/src/cs/primitive/linklet.ss b/racket/src/cs/primitive/linklet.ss index ca7ea47dda..d4e6478915 100644 --- a/racket/src/cs/primitive/linklet.ss +++ b/racket/src/cs/primitive/linklet.ss @@ -3,9 +3,8 @@ [compile-linklet (known-procedure 62)] [compiled-position->primitive (known-procedure 2)] [eval-linklet (known-procedure 2)] - [hash->linklet-bundle (known-procedure 2)] - [hash->linklet-directory (known-procedure 2)] [instance-data (known-procedure 2)] + [instance-describe-variable! (known-procedure 8)] [instance-name (known-procedure 2)] [instance-set-variable-value! (known-procedure 24)] [instance-unset-variable! (known-procedure 4)] @@ -13,10 +12,6 @@ [instance-variable-value (known-procedure 12)] [instance? (known-procedure 2)] [instantiate-linklet (known-procedure 28)] - [linklet-bundle->hash (known-procedure 2)] - [linklet-bundle? (known-procedure 2)] - [linklet-directory->hash (known-procedure 2)] - [linklet-directory? (known-procedure 2)] [linklet-export-variables (known-procedure 2)] [linklet-import-variables (known-procedure 2)] [linklet? (known-procedure 2)] diff --git a/racket/src/cs/primitive/unsafe.ss b/racket/src/cs/primitive/unsafe.ss index ccfba606cb..80134f44e1 100644 --- a/racket/src/cs/primitive/unsafe.ss +++ b/racket/src/cs/primitive/unsafe.ss @@ -9,41 +9,41 @@ [unsafe-add-post-custodian-shutdown (known-procedure 2)] [unsafe-add-collect-callbacks (known-procedure 4)] [unsafe-box*-cas! (known-procedure 8)] - [unsafe-bytes-length (known-procedure/succeeds 2)] + [unsafe-bytes-length (known-procedure/pure 2)] [unsafe-bytes-ref (known-procedure 4)] [unsafe-bytes-set! (known-procedure 8)] [unsafe-call-in-os-thread (known-procedure 2)] [unsafe-call-with-composable-continuation/no-wind (known-procedure 4)] - [unsafe-car (known-procedure/succeeds 2)] - [unsafe-cdr (known-procedure/succeeds 2)] + [unsafe-car (known-procedure/pure 2)] + [unsafe-cdr (known-procedure/pure 2)] [unsafe-chaperone-procedure (known-procedure -4)] [unsafe-chaperone-vector (known-procedure -4)] - [unsafe-char? (known-procedure/succeeds -2)] - [unsafe-char>=? (known-procedure/succeeds -2)] - [unsafe-char->integer (known-procedure/succeeds 2)] - [unsafe-cons-list (known-procedure/succeeds 4)] + [unsafe-char? (known-procedure/pure -2)] + [unsafe-char>=? (known-procedure/pure -2)] + [unsafe-char->integer (known-procedure/pure 2)] + [unsafe-cons-list (known-procedure/pure 4)] [unsafe-custodian-register (known-procedure 32)] [unsafe-custodian-unregister (known-procedure 4)] [unsafe-end-atomic (known-procedure 1)] [unsafe-end-breakable-atomic (known-procedure 1)] - [unsafe-extfl* (known-procedure/succeeds 4)] - [unsafe-extfl+ (known-procedure/succeeds 4)] - [unsafe-extfl- (known-procedure/succeeds 4)] - [unsafe-extfl->fx (known-procedure/succeeds 2)] - [unsafe-extfl/ (known-procedure/succeeds 4)] - [unsafe-extfl< (known-procedure/succeeds 4)] - [unsafe-extfl<= (known-procedure/succeeds 4)] - [unsafe-extfl= (known-procedure/succeeds 4)] - [unsafe-extfl> (known-procedure/succeeds 4)] - [unsafe-extfl>= (known-procedure/succeeds 4)] - [unsafe-extflabs (known-procedure/succeeds 2)] - [unsafe-extflmax (known-procedure/succeeds 4)] - [unsafe-extflmin (known-procedure/succeeds 4)] - [unsafe-extflsqrt (known-procedure/succeeds 2)] - [unsafe-extflvector-length (known-procedure/succeeds 2)] + [unsafe-extfl* (known-procedure/pure 4)] + [unsafe-extfl+ (known-procedure/pure 4)] + [unsafe-extfl- (known-procedure/pure 4)] + [unsafe-extfl->fx (known-procedure/pure 2)] + [unsafe-extfl/ (known-procedure/pure 4)] + [unsafe-extfl< (known-procedure/pure 4)] + [unsafe-extfl<= (known-procedure/pure 4)] + [unsafe-extfl= (known-procedure/pure 4)] + [unsafe-extfl> (known-procedure/pure 4)] + [unsafe-extfl>= (known-procedure/pure 4)] + [unsafe-extflabs (known-procedure/pure 2)] + [unsafe-extflmax (known-procedure/pure 4)] + [unsafe-extflmin (known-procedure/pure 4)] + [unsafe-extflsqrt (known-procedure/pure 2)] + [unsafe-extflvector-length (known-procedure/pure 2)] [unsafe-extflvector-ref (known-procedure 4)] [unsafe-extflvector-set! (known-procedure 8)] [unsafe-f64vector-ref (known-procedure 4)] @@ -52,66 +52,66 @@ [unsafe-f80vector-set! (known-procedure 8)] [unsafe-file-descriptor->port (known-procedure 8)] [unsafe-file-descriptor->semaphore (known-procedure 4)] - [unsafe-fl* (known-procedure/succeeds -1)] - [unsafe-fl+ (known-procedure/succeeds -1)] - [unsafe-fl- (known-procedure/succeeds -2)] - [unsafe-fl->fx (known-procedure/succeeds 2)] - [unsafe-fl/ (known-procedure/succeeds -2)] - [unsafe-fl< (known-procedure/succeeds -2)] - [unsafe-fl<= (known-procedure/succeeds -2)] - [unsafe-fl= (known-procedure/succeeds -2)] - [unsafe-fl> (known-procedure/succeeds -2)] - [unsafe-fl>= (known-procedure/succeeds -2)] - [unsafe-flabs (known-procedure/succeeds 2)] - [unsafe-flimag-part (known-procedure/succeeds 2)] - [unsafe-flmax (known-procedure/succeeds 4)] - [unsafe-flmin (known-procedure/succeeds 4)] - [unsafe-flrandom (known-procedure/succeeds 2)] - [unsafe-flreal-part (known-procedure/succeeds 2)] - [unsafe-flsqrt (known-procedure/succeeds 2)] - [unsafe-flvector-length (known-procedure/succeeds 2)] + [unsafe-fl* (known-procedure/pure -1)] + [unsafe-fl+ (known-procedure/pure -1)] + [unsafe-fl- (known-procedure/pure -2)] + [unsafe-fl->fx (known-procedure/pure 2)] + [unsafe-fl/ (known-procedure/pure -2)] + [unsafe-fl< (known-procedure/pure -2)] + [unsafe-fl<= (known-procedure/pure -2)] + [unsafe-fl= (known-procedure/pure -2)] + [unsafe-fl> (known-procedure/pure -2)] + [unsafe-fl>= (known-procedure/pure -2)] + [unsafe-flabs (known-procedure/pure 2)] + [unsafe-flimag-part (known-procedure/pure 2)] + [unsafe-flmax (known-procedure/pure 4)] + [unsafe-flmin (known-procedure/pure 4)] + [unsafe-flrandom (known-procedure/pure 2)] + [unsafe-flreal-part (known-procedure/pure 2)] + [unsafe-flsqrt (known-procedure/pure 2)] + [unsafe-flvector-length (known-procedure/pure 2)] [unsafe-flvector-ref (known-procedure 4)] [unsafe-flvector-set! (known-procedure 8)] - [unsafe-fx* (known-procedure/succeeds -1)] - [unsafe-fx+ (known-procedure/succeeds -1)] - [unsafe-fx- (known-procedure/succeeds -2)] - [unsafe-fx->extfl (known-procedure/succeeds 2)] - [unsafe-fx->fl (known-procedure/succeeds 2)] - [unsafe-fx< (known-procedure/succeeds -2)] - [unsafe-fx<= (known-procedure/succeeds -2)] - [unsafe-fx= (known-procedure/succeeds -2)] - [unsafe-fx> (known-procedure/succeeds -2)] - [unsafe-fx>= (known-procedure/succeeds -2)] - [unsafe-fxabs (known-procedure/succeeds 2)] - [unsafe-fxand (known-procedure/succeeds -1)] - [unsafe-fxior (known-procedure/succeeds -1)] - [unsafe-fxlshift (known-procedure/succeeds 4)] - [unsafe-fxmax (known-procedure/succeeds -2)] - [unsafe-fxmin (known-procedure/succeeds -2)] - [unsafe-fxmodulo (known-procedure/succeeds 4)] - [unsafe-fxnot (known-procedure/succeeds 2)] - [unsafe-fxquotient (known-procedure/succeeds 4)] - [unsafe-fxremainder (known-procedure/succeeds 4)] - [unsafe-fxrshift (known-procedure/succeeds 4)] - [unsafe-fxvector-length (known-procedure/succeeds 2)] + [unsafe-fx* (known-procedure/pure -1)] + [unsafe-fx+ (known-procedure/pure -1)] + [unsafe-fx- (known-procedure/pure -2)] + [unsafe-fx->extfl (known-procedure/pure 2)] + [unsafe-fx->fl (known-procedure/pure 2)] + [unsafe-fx< (known-procedure/pure -2)] + [unsafe-fx<= (known-procedure/pure -2)] + [unsafe-fx= (known-procedure/pure -2)] + [unsafe-fx> (known-procedure/pure -2)] + [unsafe-fx>= (known-procedure/pure -2)] + [unsafe-fxabs (known-procedure/pure 2)] + [unsafe-fxand (known-procedure/pure -1)] + [unsafe-fxior (known-procedure/pure -1)] + [unsafe-fxlshift (known-procedure/pure 4)] + [unsafe-fxmax (known-procedure/pure -2)] + [unsafe-fxmin (known-procedure/pure -2)] + [unsafe-fxmodulo (known-procedure/pure 4)] + [unsafe-fxnot (known-procedure/pure 2)] + [unsafe-fxquotient (known-procedure/pure 4)] + [unsafe-fxremainder (known-procedure/pure 4)] + [unsafe-fxrshift (known-procedure/pure 4)] + [unsafe-fxvector-length (known-procedure/pure 2)] [unsafe-fxvector-ref (known-procedure 4)] [unsafe-fxvector-set! (known-procedure 8)] - [unsafe-fxxor (known-procedure/succeeds -1)] + [unsafe-fxxor (known-procedure/pure -1)] [unsafe-get-place-table (known-procedure 1)] - [unsafe-immutable-hash-iterate-first (known-procedure/succeeds 2)] - [unsafe-immutable-hash-iterate-key (known-procedure/succeeds 4)] - [unsafe-immutable-hash-iterate-key+value (known-procedure/succeeds 4)] - [unsafe-immutable-hash-iterate-next (known-procedure/succeeds 4)] - [unsafe-immutable-hash-iterate-pair (known-procedure/succeeds 4)] - [unsafe-immutable-hash-iterate-value (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-first (known-procedure/pure 2)] + [unsafe-immutable-hash-iterate-key (known-procedure/pure 4)] + [unsafe-immutable-hash-iterate-key+value (known-procedure/pure 4)] + [unsafe-immutable-hash-iterate-next (known-procedure/pure 4)] + [unsafe-immutable-hash-iterate-pair (known-procedure/pure 4)] + [unsafe-immutable-hash-iterate-value (known-procedure/pure 4)] [unsafe-impersonate-procedure (known-procedure -4)] [unsafe-impersonate-vector (known-procedure -4)] [unsafe-in-atomic? (known-procedure 1)] - [unsafe-list-ref (known-procedure/succeeds 4)] - [unsafe-list-tail (known-procedure/succeeds 4)] + [unsafe-list-ref (known-procedure/pure 4)] + [unsafe-list-tail (known-procedure/pure 4)] [unsafe-make-custodian-at-root (known-procedure 1)] - [unsafe-make-flrectangular (known-procedure/succeeds 4)] - [unsafe-make-place-local (known-procedure/succeeds 2)] + [unsafe-make-flrectangular (known-procedure/pure 4)] + [unsafe-make-place-local (known-procedure/pure 2)] [unsafe-make-os-semaphore (known-procedure 1)] [unsafe-make-security-guard-at-root (known-procedure 15)] [unsafe-mcar (known-procedure 2)] @@ -125,8 +125,8 @@ [unsafe-os-semaphore-post (known-procedure 2)] [unsafe-os-semaphore-wait (known-procedure 2)] [unsafe-os-thread-enabled? (known-procedure 1)] - [unsafe-place-local-ref (known-procedure/succeeds 2)] - [unsafe-place-local-set! (known-procedure/succeeds 4)] + [unsafe-place-local-ref (known-procedure/pure 2)] + [unsafe-place-local-set! (known-procedure/pure 4)] [unsafe-poll-ctx-eventmask-wakeup (known-procedure 4)] [unsafe-poll-ctx-fd-wakeup (known-procedure 8)] [unsafe-poll-ctx-milliseconds-wakeup (known-procedure 4)] @@ -135,7 +135,7 @@ [unsafe-port->socket (known-procedure 2)] [unsafe-register-process-global (known-procedure 4)] [unsafe-remove-collect-callbacks (known-procedure 2)] - [unsafe-root-continuation-prompt-tag (known-procedure/succeeds 1)] + [unsafe-root-continuation-prompt-tag (known-procedure/pure 1)] [unsafe-s16vector-ref (known-procedure 4)] [unsafe-s16vector-set! (known-procedure 8)] [unsafe-set-box! (known-procedure 4)] @@ -149,13 +149,13 @@ [unsafe-socket->semaphore (known-procedure 4)] [unsafe-start-atomic (known-procedure 1)] [unsafe-start-breakable-atomic (known-procedure 1)] - [unsafe-string-length (known-procedure/succeeds 2)] - [unsafe-string-ref (known-procedure/succeeds 4)] - [unsafe-string-set! (known-procedure/succeeds 8)] - [unsafe-struct*-ref (known-procedure/succeeds 4)] - [unsafe-struct*-set! (known-procedure/succeeds 8)] - [unsafe-struct-ref (known-procedure/succeeds 4)] - [unsafe-struct-set! (known-procedure/succeeds 8)] + [unsafe-string-length (known-procedure/pure 2)] + [unsafe-string-ref (known-procedure/pure 4)] + [unsafe-string-set! (known-procedure/pure 8)] + [unsafe-struct*-ref (known-procedure/pure 4)] + [unsafe-struct*-set! (known-procedure/pure 8)] + [unsafe-struct-ref (known-procedure/pure 4)] + [unsafe-struct-set! (known-procedure/pure 8)] [unsafe-thread-at-root (known-procedure 2)] [unsafe-u16vector-ref (known-procedure 4)] [unsafe-u16vector-set! (known-procedure 8)] @@ -163,10 +163,10 @@ [unsafe-unbox* (known-procedure 2)] [unsafe-undefined (known-constant)] [unsafe-vector*-cas! (known-procedure 16)] - [unsafe-vector*-length (known-procedure/succeeds 2)] + [unsafe-vector*-length (known-procedure/pure 2)] [unsafe-vector*-ref (known-procedure 4)] [unsafe-vector*-set! (known-procedure 8)] - [unsafe-vector-length (known-procedure/succeeds 2)] + [unsafe-vector-length (known-procedure/pure 2)] [unsafe-vector-ref (known-procedure 4)] [unsafe-vector-set! (known-procedure 8)] [unsafe-weak-hash-iterate-first (known-procedure 2)] diff --git a/racket/src/cs/schemify.sls b/racket/src/cs/schemify.sls index b4c871b25e..22a801be9b 100644 --- a/racket/src/cs/schemify.sls +++ b/racket/src/cs/schemify.sls @@ -8,6 +8,8 @@ linklet-bigger-than? prim-knowns known-procedure + known-procedure/pure + known-procedure/succeeds a-known-constant) (import (except (chezpart) datum->syntax) diff --git a/racket/src/expander/compile/form.rkt b/racket/src/expander/compile/form.rkt index 7c6e5b96f8..1e883f6734 100644 --- a/racket/src/expander/compile/form.rkt +++ b/racket/src/expander/compile/form.rkt @@ -46,6 +46,7 @@ #:other-form-callback [other-form-callback void] #:get-module-linklet-info [get-module-linklet-info (lambda (mod-name p) #f)] ; to support submodules #:serializable? [serializable? #t] + #:module-prompt? [module-prompt? #f] #:to-correlated-linklet? [to-correlated-linklet? #f] #:cross-linklet-inlining? [cross-linklet-inlining? #t]) (define phase (compile-context-phase cctx)) @@ -276,6 +277,7 @@ #:body-import-instances body-import-instances #:get-module-linklet-info get-module-linklet-info #:serializable? serializable? + #:module-prompt? module-prompt? #:module-use*s module-use*s #:cross-linklet-inlining? cross-linklet-inlining? #:namespace (compile-context-namespace cctx))])) @@ -391,6 +393,7 @@ #:body-import-instances body-import-instances #:get-module-linklet-info get-module-linklet-info #:serializable? serializable? + #:module-prompt? module-prompt? #:module-use*s module-use*s #:cross-linklet-inlining? cross-linklet-inlining? #:namespace namespace) @@ -398,7 +401,13 @@ (performance-region ['compile '_ 'linklet] ((lambda (l name keys getter) - (compile-linklet l name keys getter (if serializable? '(serializable) '()))) + (compile-linklet l name keys getter (if serializable? + (if module-prompt? + '(serializable use-prompt) + '(serializable)) + (if module-prompt? + '(use-prompt) + '())))) body-linklet 'module ;; Support for cross-module optimization starts with a vector diff --git a/racket/src/expander/compile/instance.rkt b/racket/src/expander/compile/instance.rkt index 3a25447ed2..e966e1ae4a 100644 --- a/racket/src/expander/compile/instance.rkt +++ b/racket/src/expander/compile/instance.rkt @@ -44,9 +44,15 @@ (make-instance 'empty-stx #f 'constant get-syntax-literal!-id (lambda (pos) #f) 'get-encoded-root-expand-ctx #f)) +(void (instance-describe-variable! empty-syntax-literals-instance + get-syntax-literal!-id + '(procedure/succeeds 2))) (define empty-module-body-instance (make-module-body-instance-instance #:set-transformer! (lambda (name val) (void)))) +(void (instance-describe-variable! empty-module-body-instance + set-transformer!-id + '(procedure/succeeds 4))) (define empty-top-syntax-literal-instance (make-instance 'top-syntax-literal #f 'constant diff --git a/racket/src/expander/compile/module.rkt b/racket/src/expander/compile/module.rkt index a60da92b9f..2ce9632c31 100644 --- a/racket/src/expander/compile/module.rkt +++ b/racket/src/expander/compile/module.rkt @@ -172,6 +172,7 @@ (hash-ref modules-being-compiled mod-name #f))) (and ht (hash-ref ht phase #f))) #:serializable? serializable? + #:module-prompt? #t #:to-correlated-linklet? to-correlated-linklet?)) (when modules-being-compiled diff --git a/racket/src/expander/compile/recompile.rkt b/racket/src/expander/compile/recompile.rkt index 1bbeeb2a17..138dee5eb3 100644 --- a/racket/src/expander/compile/recompile.rkt +++ b/racket/src/expander/compile/recompile.rkt @@ -175,6 +175,7 @@ empty-module-body-instance) #:get-module-linklet-info find-submodule #:serializable? #t + #:module-prompt? #t #:module-use*s module-use*s #:cross-linklet-inlining? #t #:namespace ns)) diff --git a/racket/src/expander/expand/main.rkt b/racket/src/expander/expand/main.rkt index e54c7dee50..bf7df1adf4 100644 --- a/racket/src/expander/expand/main.rkt +++ b/racket/src/expander/expand/main.rkt @@ -672,13 +672,15 @@ #:phase phase)))) (define vals (call-with-values (lambda () - (parameterize ([current-namespace ns] - [eval-jit-enabled #f]) - (parameterize-like - #:with ([current-expand-context ctx]) - (if compiled - (eval-single-top compiled ns) - (direct-eval p ns (root-expand-context-self-mpi ctx)))))) + (call-with-continuation-barrier + (lambda () + (parameterize ([current-namespace ns] + [eval-jit-enabled #f]) + (parameterize-like + #:with ([current-expand-context ctx]) + (if compiled + (eval-single-top compiled ns) + (direct-eval p ns (root-expand-context-self-mpi ctx)))))))) list)) (unless (= (length vals) (length ids)) (apply raise-result-arity-error diff --git a/racket/src/expander/run/linklet-operation.rkt b/racket/src/expander/run/linklet-operation.rkt index 41006dafdf..ffc31432a7 100644 --- a/racket/src/expander/run/linklet-operation.rkt +++ b/racket/src/expander/run/linklet-operation.rkt @@ -31,6 +31,7 @@ instance-variable-value instance-set-variable-value! instance-unset-variable! + instance-describe-variable! linklet-virtual-machine-bytes write-linklet-bundle-hash diff --git a/racket/src/expander/run/linklet.rkt b/racket/src/expander/run/linklet.rkt index 59ba8934c9..f9735518b0 100644 --- a/racket/src/expander/run/linklet.rkt +++ b/racket/src/expander/run/linklet.rkt @@ -99,6 +99,9 @@ [(procedure? fail-k) (fail-k)] [else fail-k])) +(define (instance-describe-variable! i sym desc) + (void)) + ;; ---------------------------------------- (define undefined (gensym 'undefined)) diff --git a/racket/src/racket/src/cify-startup.rkt b/racket/src/racket/src/cify-startup.rkt index 86a6eb5cab..26c9d47c66 100644 --- a/racket/src/racket/src/cify-startup.rkt +++ b/racket/src/racket/src/cify-startup.rkt @@ -78,6 +78,8 @@ ;; for cify: #t ;; unsafe mode: + #t + ;; no prompts: #t))) (printf "Lift...\n") diff --git a/racket/src/racket/src/linklet.c b/racket/src/racket/src/linklet.c index 449a641598..d73580e993 100644 --- a/racket/src/racket/src/linklet.c +++ b/racket/src/racket/src/linklet.c @@ -37,6 +37,7 @@ SHARED_OK static int recompile_every_compile = 0; static Scheme_Object *serializable_symbol; static Scheme_Object *unsafe_symbol; static Scheme_Object *static_symbol; +static Scheme_Object *use_prompt_symbol; static Scheme_Object *constant_symbol; static Scheme_Object *consistent_symbol; static Scheme_Object *noncm_symbol; @@ -74,6 +75,7 @@ static Scheme_Object *instance_variable_names(int argc, Scheme_Object **argv); static Scheme_Object *instance_variable_value(int argc, Scheme_Object **argv); static Scheme_Object *instance_set_variable_value(int argc, Scheme_Object **argv); static Scheme_Object *instance_unset_variable(int argc, Scheme_Object **argv); +static Scheme_Object *instance_describe_variable(int argc, Scheme_Object **argv); static Scheme_Object *variable_p(int argc, Scheme_Object **argv); static Scheme_Object *variable_instance(int argc, Scheme_Object **argv); @@ -121,9 +123,11 @@ void scheme_init_linklet(Scheme_Startup_Env *env) REGISTER_SO(serializable_symbol); REGISTER_SO(unsafe_symbol); REGISTER_SO(static_symbol); + REGISTER_SO(use_prompt_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"); REGISTER_SO(constant_symbol); REGISTER_SO(consistent_symbol); @@ -165,6 +169,7 @@ void scheme_init_linklet(Scheme_Startup_Env *env) ADD_PRIM_W_ARITY2("instance-variable-value", instance_variable_value, 2, 3, 0, -1, env); ADD_PRIM_W_ARITY("instance-set-variable-value!", instance_set_variable_value, 3, 4, env); ADD_PRIM_W_ARITY("instance-unset-variable!", instance_unset_variable, 2, 2, env); + ADD_PRIM_W_ARITY("instance-describe-variable!", instance_describe_variable, 3, 3, env); ADD_FOLDING_PRIM_UNARY_INLINED("variable-reference?", variable_p, 1, 1, 1, env); ADD_IMMED_PRIM("variable-reference->instance", variable_instance, 1, 2, env); @@ -373,6 +378,7 @@ static void parse_compile_options(const char *who, int arg_pos, int serializable = 0; int unsafe = *_unsafe; int static_mode = *_static_mode; + int use_prompt_mode = 0; while (SCHEME_PAIRP(flags)) { flag = SCHEME_CAR(flags); @@ -388,13 +394,17 @@ static void parse_compile_options(const char *who, int arg_pos, if (static_mode && !redundant) redundant = flag; static_mode = 1; + } else if (SAME_OBJ(flag, use_prompt_symbol)) { + if (use_prompt_mode && !redundant) + redundant = flag; + use_prompt_mode = 1; } else break; flags = SCHEME_CDR(flags); } if (!SCHEME_NULLP(flags)) - scheme_wrong_contract("compile-linklet", "(listof/c 'serializable 'unsafe)", arg_pos, argc, argv); + scheme_wrong_contract("compile-linklet", "(listof/c 'serializable 'unsafe 'static 'use-prompt)", arg_pos, argc, argv); if (redundant) scheme_contract_error("compile-linklet", "redundant option", @@ -835,6 +845,16 @@ static Scheme_Object *instance_unset_variable(int argc, Scheme_Object **argv) return scheme_void; } +static Scheme_Object *instance_describe_variable(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-describe-variable!", "instance?", 0, argc, argv); + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("instance-describe-variable!", "symbol?", 1, argc, argv); + + return scheme_void; +} + static Scheme_Object *variable_p(int argc, Scheme_Object **argv) { return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type) diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index fca5fb2a43..3cf3764601 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -14,7 +14,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1448 +#define EXPECTED_PRIM_COUNT 1449 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index c34a0d0c94..1abfa65a87 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "7.1.0.7" +#define MZSCHEME_VERSION "7.1.0.8" #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 7 +#define MZSCHEME_VERSION_W 8 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 4e3b285bc1..9e5b79e566 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -11954,6 +11954,7 @@ static const char *startup_source = "(define-values(1/instance-variable-value) instance-variable-value)" "(define-values(1/instance-set-variable-value!) instance-set-variable-value!)" "(define-values(1/instance-unset-variable!) instance-unset-variable!)" +"(define-values(1/instance-describe-variable!) instance-describe-variable!)" "(define-values(1/linklet-virtual-machine-bytes) linklet-virtual-machine-bytes)" "(define-values(1/write-linklet-bundle-hash) write-linklet-bundle-hash)" "(define-values(1/read-linklet-bundle-hash) read-linklet-bundle-hash)" @@ -30258,9 +30259,11 @@ static const char *startup_source = "(define-values" "(empty-syntax-literals-instance)" "(1/make-instance 'empty-stx #f 'constant get-syntax-literal!-id(lambda(pos_0) #f) 'get-encoded-root-expand-ctx #f))" +"(void(1/instance-describe-variable! empty-syntax-literals-instance 'get-syntax-literal!-id '(procedure/succeeds 2)))" "(define-values" "(empty-module-body-instance)" "(let-values(((temp21_0)(lambda(name_0 val_0)(void))))(make-module-body-instance-instance18.1 temp21_0)))" +"(void(1/instance-describe-variable! empty-module-body-instance 'set-transformer!-id '(procedure/succeeds 4)))" "(define-values" "(empty-top-syntax-literal-instance)" "(1/make-instance 'top-syntax-literal #f 'constant mpi-vector-id #f syntax-literals-id #f))" @@ -31407,28 +31410,29 @@ static const char *startup_source = "(make-struct-field-accessor -ref_0 2 'extra-inspectorsss)" "(make-struct-field-accessor -ref_0 3 'def-decls))))" "(define-values" -"(compile-forms31.1)" +"(compile-forms33.1)" "(lambda(body-import-instances3_0" " body-imports2_0" " body-suffix-forms4_0" " compiled-expression-callback8_0" -" cross-linklet-inlining?14_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" " other-form-callback10_0" " root-ctx-only-if-syntax?7_0" " serializable?12_0" -" to-correlated-linklet?13_0" -" bodys28_0" -" cctx29_0" -" mpis30_0)" +" to-correlated-linklet?14_0" +" bodys30_0" +" cctx31_0" +" mpis32_0)" "(begin" -" 'compile-forms31" -"(let-values(((bodys_0) bodys28_0))" -"(let-values(((cctx_0) cctx29_0))" -"(let-values(((mpis_0) mpis30_0))" +" 'compile-forms33" +"(let-values(((bodys_0) bodys30_0))" +"(let-values(((cctx_0) cctx31_0))" +"(let-values(((mpis_0) mpis32_0))" "(let-values(((body-imports_0) body-imports2_0))" "(let-values(((body-import-instances_0) body-import-instances3_0))" "(let-values(((body-suffix-forms_0) body-suffix-forms4_0))" @@ -31450,8 +31454,9 @@ static const char *startup_source = "(lambda(mod-name_0 p_0)(begin 'get-module-linklet-info #f))" " get-module-linklet-info11_0)))" "(let-values(((serializable?_0) serializable?12_0))" -"(let-values(((to-correlated-linklet?_0) to-correlated-linklet?13_0))" -"(let-values(((cross-linklet-inlining?_0) cross-linklet-inlining?14_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()" "(let-values(((phase_0)(compile-context-phase cctx_0)))" "(let-values(((self_0)(compile-context-self cctx_0)))" @@ -31832,26 +31837,26 @@ static const char *startup_source = "(let-values()" "(cons" "(let-values()" -"(let-values(((header55_0)" +"(let-values(((header59_0)" " header_0)" -"((temp56_0)" +"((temp60_0)" "(compile-context-self" " cctx_0))" -"((phase57_0)" +"((phase61_0)" " phase_1)" -"((binding-sym58_0)" +"((binding-sym62_0)" " binding-sym_0)" -"((temp59_0)" +"((temp63_0)" " #f)" -"((temp60_0)" +"((temp64_0)" " #t))" "(register-required-variable-use!19.1" +" temp64_0" +" header59_0" " temp60_0" -" header55_0" -" temp56_0" -" phase57_0" -" binding-sym58_0" -" temp59_0)))" +" phase61_0" +" binding-sym62_0" +" temp63_0)))" " fold-var_1))))" "(values" " fold-var_2)))))" @@ -31873,14 +31878,14 @@ static const char *startup_source = " cctx_0))" "(if(compile-context?" " the-struct_0)" -"(let-values(((phase61_0)" +"(let-values(((phase65_0)" " phase_1)" -"((header62_0)" +"((header66_0)" " header_0))" "(compile-context1.1" "(compile-context-namespace" " the-struct_0)" -" phase61_0" +" phase65_0" "(compile-context-self" " the-struct_0)" "(compile-context-module-self" @@ -31889,10 +31894,10 @@ static const char *startup_source = " the-struct_0)" "(compile-context-lazy-syntax-literals?" " the-struct_0)" -" header62_0))" +" header66_0))" "(raise-argument-error" " 'struct-copy" -" \"compile-context?\"" +" \"compile-context?\"" " the-struct_0)))" "(if(=" "(length" @@ -31996,14 +32001,14 @@ static const char *startup_source = " cctx_0))" "(if(compile-context?" " the-struct_0)" -"(let-values(((phase63_0)" +"(let-values(((phase67_0)" " phase_1)" -"((header64_0)" +"((header68_0)" " header_0))" "(compile-context1.1" "(compile-context-namespace" " the-struct_0)" -" phase63_0" +" phase67_0" "(compile-context-self" " the-struct_0)" "(compile-context-module-self" @@ -32012,10 +32017,10 @@ static const char *startup_source = " the-struct_0)" "(compile-context-lazy-syntax-literals?" " the-struct_0)" -" header64_0))" +" header68_0))" "(raise-argument-error" " 'struct-copy" -" \"compile-context?\"" +" \"compile-context?\"" " the-struct_0)))" " #f)))))))))))" "(if(parsed-define-syntaxes?" @@ -32092,15 +32097,15 @@ static const char *startup_source = " cctx_0))" "(if(compile-context?" " the-struct_0)" -"(let-values(((phase65_0)" +"(let-values(((phase69_0)" "(add1" " phase_1))" -"((header66_0)" +"((header70_0)" " next-header_0))" "(compile-context1.1" "(compile-context-namespace" " the-struct_0)" -" phase65_0" +" phase69_0" "(compile-context-self" " the-struct_0)" "(compile-context-module-self" @@ -32109,10 +32114,10 @@ static const char *startup_source = " the-struct_0)" "(compile-context-lazy-syntax-literals?" " the-struct_0)" -" header66_0))" +" header70_0))" "(raise-argument-error" " 'struct-copy" -" \"compile-context?\"" +" \"compile-context?\"" " the-struct_0))))))" "(let-values((()" "(begin" @@ -32232,14 +32237,14 @@ static const char *startup_source = " cctx_0))" "(if(compile-context?" " the-struct_0)" -"(let-values(((phase67_0)" +"(let-values(((phase71_0)" " phase_1)" -"((header68_0)" +"((header72_0)" " header_0))" "(compile-context1.1" "(compile-context-namespace" " the-struct_0)" -" phase67_0" +" phase71_0" "(compile-context-self" " the-struct_0)" "(compile-context-module-self" @@ -32248,10 +32253,10 @@ static const char *startup_source = " the-struct_0)" "(compile-context-lazy-syntax-literals?" " the-struct_0)" -" header68_0))" +" header72_0))" "(raise-argument-error" " 'struct-copy" -" \"compile-context?\"" +" \"compile-context?\"" " the-struct_0)))" " gen-syms_0)))))" "(set! saw-define-syntaxes?_0" @@ -32287,14 +32292,14 @@ static const char *startup_source = " cctx_0))" "(if(compile-context?" " the-struct_0)" -"(let-values(((phase69_0)" +"(let-values(((phase73_0)" " phase_1)" -"((header70_0)" +"((header74_0)" " header_0))" "(compile-context1.1" "(compile-context-namespace" " the-struct_0)" -" phase69_0" +" phase73_0" "(compile-context-self" " the-struct_0)" "(compile-context-module-self" @@ -32303,10 +32308,10 @@ static const char *startup_source = " the-struct_0)" "(compile-context-lazy-syntax-literals?" " the-struct_0)" -" header70_0))" +" header74_0))" "(raise-argument-error" " 'struct-copy" -" \"compile-context?\"" +" \"compile-context?\"" " the-struct_0))))))" "(if e_0" "(let-values()" @@ -32329,14 +32334,14 @@ static const char *startup_source = " cctx_0))" "(if(compile-context?" " the-struct_0)" -"(let-values(((phase71_0)" +"(let-values(((phase75_0)" " phase_1)" -"((header72_0)" +"((header76_0)" " header_0))" "(compile-context1.1" "(compile-context-namespace" " the-struct_0)" -" phase71_0" +" phase75_0" "(compile-context-self" " the-struct_0)" "(compile-context-module-self" @@ -32345,10 +32350,10 @@ static const char *startup_source = " the-struct_0)" "(compile-context-lazy-syntax-literals?" " the-struct_0)" -" header72_0))" +" header76_0))" "(raise-argument-error" " 'struct-copy" -" \"compile-context?\"" +" \"compile-context?\"" " the-struct_0)))" " #f" "(=" @@ -32404,11 +32409,15 @@ static const char *startup_source = " #f)" " #f)))" "(let-values(((phases-in-order_0)" -"(let-values(((temp73_0)" +"(let-values(((temp77_0)" "(hash-keys" " phase-to-body_0))" -"((<74_0) <))" -"(sort7.1 #f #f temp73_0 <74_0))))" +"((<78_0) <))" +"(sort7.1" +" #f" +" #f" +" temp77_0" +" <78_0))))" "(let-values(((min-phase_0)" "(if(pair? phases-in-order_0)" "(car phases-in-order_0)" @@ -32494,7 +32503,8 @@ static const char *startup_source = "(#%variable-reference))" "(void)" "(let-values()" -"(check-list lst_0)))" +"(check-list" +" lst_0)))" "((letrec-values(((for-loop_0)" "(lambda(table_0" " lst_1)" @@ -32616,33 +32626,36 @@ static const char *startup_source = " 'module)" " module-use*s_0))" "(let-values()" -"(let-values(((body-linklet75_0)" +"(let-values(((body-linklet79_0)" " body-linklet_0)" -"((body-imports76_0)" +"((body-imports80_0)" " body-imports_0)" -"((body-import-instances77_0)" +"((body-import-instances81_0)" " body-import-instances_0)" -"((get-module-linklet-info78_0)" +"((get-module-linklet-info82_0)" " get-module-linklet-info_0)" -"((serializable?79_0)" +"((serializable?83_0)" " serializable?_0)" -"((module-use*s80_0)" +"((module-prompt?84_0)" +" module-prompt?_0)" +"((module-use*s85_0)" " module-use*s_0)" -"((cross-linklet-inlining?81_0)" +"((cross-linklet-inlining?86_0)" " cross-linklet-inlining?_0)" -"((temp82_0)" +"((temp87_0)" "(compile-context-namespace" " cctx_0)))" -"(compile-module-linklet51.1" -" body-import-instances77_0" -" body-imports76_0" +"(compile-module-linklet55.1" +" body-import-instances81_0" +" body-imports80_0" " unsafe-undefined" -" cross-linklet-inlining?81_0" -" get-module-linklet-info78_0" -" module-use*s80_0" -" temp82_0" -" serializable?79_0" -" body-linklet75_0))))))" +" cross-linklet-inlining?86_0" +" get-module-linklet-info82_0" +" module-prompt?84_0" +" module-use*s85_0" +" temp87_0" +" serializable?83_0" +" body-linklet79_0))))))" "(values" " phase_1" "(cons" @@ -32859,7 +32872,7 @@ static const char *startup_source = " phase-to-link-module-uses-expr_0" " phase-to-link-extra-inspectorsss_0" " syntax-literals_0" -" encoded-root-expand-pos_0)))))))))))))))))))))))))))))))))))))))))))))" +" encoded-root-expand-pos_0))))))))))))))))))))))))))))))))))))))))))))))" "(define-values" "(compile-top-level-bind)" "(lambda(ids_0 binding-syms_0 cctx_0 trans-exprs_0)" @@ -33016,28 +33029,30 @@ static const char *startup_source = "(let-values(((v_0)(syntax-property$1 orig-s_0 'compiler-hint:cross-module-inline)))" "(if v_0(correlated-property e_0 'compiler-hint:cross-module-inline v_0) e_0)))))" "(define-values" -"(compile-module-linklet51.1)" -"(lambda(body-import-instances36_0" -" body-imports35_0" -" compile-linklet34_0" -" cross-linklet-inlining?40_0" -" get-module-linklet-info37_0" -" module-use*s39_0" -" namespace41_0" -" serializable?38_0" -" body-linklet50_0)" +"(compile-module-linklet55.1)" +"(lambda(body-import-instances38_0" +" body-imports37_0" +" compile-linklet36_0" +" cross-linklet-inlining?43_0" +" get-module-linklet-info39_0" +" module-prompt?41_0" +" module-use*s42_0" +" namespace44_0" +" serializable?40_0" +" body-linklet54_0)" "(begin" -" 'compile-module-linklet51" -"(let-values(((body-linklet_0) body-linklet50_0))" +" 'compile-module-linklet55" +"(let-values(((body-linklet_0) body-linklet54_0))" "(let-values(((compile-linklet_0)" -"(if(eq? compile-linklet34_0 unsafe-undefined) 1/compile-linklet compile-linklet34_0)))" -"(let-values(((body-imports_0) body-imports35_0))" -"(let-values(((body-import-instances_0) body-import-instances36_0))" -"(let-values(((get-module-linklet-info_0) get-module-linklet-info37_0))" -"(let-values(((serializable?_0) serializable?38_0))" -"(let-values(((module-use*s_0) module-use*s39_0))" -"(let-values(((cross-linklet-inlining?_0) cross-linklet-inlining?40_0))" -"(let-values(((namespace_0) namespace41_0))" +"(if(eq? compile-linklet36_0 unsafe-undefined) 1/compile-linklet compile-linklet36_0)))" +"(let-values(((body-imports_0) body-imports37_0))" +"(let-values(((body-import-instances_0) body-import-instances38_0))" +"(let-values(((get-module-linklet-info_0) get-module-linklet-info39_0))" +"(let-values(((serializable?_0) serializable?40_0))" +"(let-values(((module-prompt?_0) module-prompt?41_0))" +"(let-values(((module-use*s_0) module-use*s42_0))" +"(let-values(((cross-linklet-inlining?_0) cross-linklet-inlining?43_0))" +"(let-values(((namespace_0) namespace44_0))" "(let-values()" "(let-values(((linklet_0 new-module-use*s_0)" "(begin" @@ -33052,7 +33067,9 @@ static const char *startup_source = " name_0" " keys_0" " getter_0" -"(if serializable?_0 '(serializable) '())))" +"(if serializable?_0" +"(if module-prompt?_0 '(serializable use-prompt) '(serializable))" +"(if module-prompt?_0 '(use-prompt) '()))))" " body-linklet_0" " 'module" "(list->vector(append body-import-instances_0 module-use*s_0))" @@ -33064,7 +33081,7 @@ static const char *startup_source = "(if log-performance?(let-values()(end-performance-region))(void))))))" "(values" " linklet_0" -"(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" "(make-module-use-to-linklet)" "(lambda(cross-linklet-inlining?_0 ns_0 get-module-linklet-info_0 init-mu*s_0)" @@ -36372,7 +36389,7 @@ static const char *startup_source = "(set! purely-functional?_0 #f)" "(compile-top-level-require s_0 cctx_1))))" "((temp26_0)(not single-expression?_0)))" -"(compile-forms31.1" +"(compile-forms33.1" " temp20_0" " temp19_0" " null" @@ -36382,6 +36399,7 @@ static const char *startup_source = " #f" " null" " unsafe-undefined" +" #f" " temp25_0" " #f" " serializable?21_0" @@ -39193,15 +39211,15 @@ static const char *startup_source = " body_0)" "(let-values()" "(let-values(((ok?_0" -" _69_0" -" kw70_0)" +" _70_0" +" kw71_0)" "(let-values(((s_0)" "(parsed-s" " body_0)))" "(let-values(((orig-s_0)" " s_0))" -"(let-values(((_69_0" -" kw70_0)" +"(let-values(((_70_0" +" kw71_0)" "(let-values(((s_1)" "(if(syntax?$1" " s_0)" @@ -39210,12 +39228,12 @@ static const char *startup_source = " s_0)))" "(if(pair?" " s_1)" -"(let-values(((_71_0)" +"(let-values(((_72_0)" "(let-values(((s_2)" "(car" " s_1)))" " s_2))" -"((kw72_0)" +"((kw73_0)" "(let-values(((s_2)" "(cdr" " s_1)))" @@ -39238,19 +39256,19 @@ static const char *startup_source = "(let-values()" " flat-s_0)))))))" "(values" -" _71_0" -" kw72_0))" +" _72_0" +" kw73_0))" "(raise-syntax-error$1" " #f" " \"bad syntax\"" " orig-s_0)))))" "(values" " #t" -" _69_0" -" kw70_0))))))" +" _70_0" +" kw71_0))))))" "(begin" "(let-values(((lst_0)" -" kw70_0))" +" kw71_0))" "(begin" "(if(variable-reference-from-unsafe?" "(#%variable-reference))" @@ -39327,9 +39345,10 @@ static const char *startup_source = " #f))))" "((serializable?67_0)" " serializable?_0)" -"((to-correlated-linklet?68_0)" +"((temp68_0) #t)" +"((to-correlated-linklet?69_0)" " to-correlated-linklet?_0))" -"(compile-forms31.1" +"(compile-forms33.1" " temp59_0" " temp58_0" " temp60_0" @@ -39339,10 +39358,11 @@ static const char *startup_source = " encoded-root-expand-ctx-box62_0" " temp61_0" " temp66_0" +" temp68_0" " temp65_0" " body-context-simple?63_0" " serializable?67_0" -" to-correlated-linklet?68_0" +" to-correlated-linklet?69_0" " bodys55_0" " body-cctx56_0" " mpis57_0))))" @@ -39506,20 +39526,20 @@ static const char *startup_source = " get-syntax-literal!-id" " '(get-encoded-root-expand-ctx))" "(qq-append" -"(let-values(((syntax-literals73_0)" +"(let-values(((syntax-literals74_0)" " syntax-literals_0)" -"((mpis74_0)" +"((mpis75_0)" " mpis_0)" -"((self75_0)" +"((self76_0)" " self_0)" -"((temp76_0)" +"((temp77_0)" "(not" " serializable?_0)))" "(generate-lazy-syntax-literals!9.1" -" temp76_0" -" syntax-literals73_0" -" mpis74_0" -" self75_0))" +" temp77_0" +" syntax-literals74_0" +" mpis75_0" +" self76_0))" "(list" "(list" " 'define-values" @@ -39718,16 +39738,16 @@ static const char *startup_source = "(hash-set" " bundle_10" " 'side-effects" -"(let-values(((temp77_0)" +"(let-values(((temp78_0)" "(hash-keys" " side-effects_0))" -"((<78_0)" +"((<79_0)" " <))" "(sort7.1" " #f" " #f" -" temp77_0" -" <78_0)))" +" temp78_0" +" <79_0)))" " bundle_10)))" "(let-values(((bundle_12)" "(if empty-result-for-module->namespace?_0" @@ -40354,20 +40374,23 @@ static const char *startup_source = " find-submodule_0)" "((temp8_0)" " #t)" -"((module-use*s9_0)" -" module-use*s_0)" -"((temp10_0)" +"((temp9_0)" " #t)" -"((ns11_0)" +"((module-use*s10_0)" +" module-use*s_0)" +"((temp11_0)" +" #t)" +"((ns12_0)" " ns_0))" -"(compile-module-linklet51.1" +"(compile-module-linklet55.1" " temp6_0" " temp5_0" " temp4_0" -" temp10_0" +" temp11_0" " find-submodule7_0" -" module-use*s9_0" -" ns11_0" +" temp9_0" +" module-use*s10_0" +" ns12_0" " temp8_0" " temp3_0))))" "(values" @@ -43828,6 +43851,8 @@ static const char *startup_source = "(let-values(((vals_0)" "(call-with-values" "(lambda()" +"(call-with-continuation-barrier" +"(lambda()" "(with-continuation-mark" " parameterization-key" "(extend-parameterization" @@ -43843,7 +43868,7 @@ static const char *startup_source = "(let-values()" "(if compiled_0" "(eval-single-top compiled_0 ns_0)" -"(direct-eval p_0 ns_0(root-expand-context-self-mpi ctx_0))))))))" +"(direct-eval p_0 ns_0(root-expand-context-self-mpi ctx_0))))))))))" " list)))" "(begin" "(if(=(length vals_0)(length ids_0))" @@ -63383,6 +63408,8 @@ static const char *startup_source = " 1/instance-set-variable-value!" " 'instance-unset-variable!" " 1/instance-unset-variable!" +" 'instance-describe-variable!" +" 1/instance-describe-variable!" " 'linklet-virtual-machine-bytes" " 1/linklet-virtual-machine-bytes" " 'write-linklet-bundle-hash" diff --git a/racket/src/schemify/find-definition.rkt b/racket/src/schemify/find-definition.rkt index dca4ac4bd3..88dc3c4169 100644 --- a/racket/src/schemify/find-definition.rkt +++ b/racket/src/schemify/find-definition.rkt @@ -106,4 +106,22 @@ (hash-set knowns (unwrap prop:s) (known-struct-type-property/immediate-guard))] [else knowns])) #f)] + [`(define-values ,ids ,rhs) + (let loop ([rhs rhs]) + (match rhs + [`(let-values () ,rhs) (loop rhs)] + [`(values ,rhss ...) + (cond + [(equal? (length ids) (length rhss)) + (values + (for/fold ([knowns knowns]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (define-values (new-knowns info) + (find-definitions `(define-values (,id) ,rhs) + prim-knowns knowns imports mutated unsafe-mode? + #:optimize? optimize?)) + new-knowns) + #f)] + [else (values knowns #f)])] + [`,_ (values knowns #f)]))] [`,_ (values knowns #f)])) diff --git a/racket/src/schemify/known.rkt b/racket/src/schemify/known.rkt index d3a54c0ac5..f18386c5ab 100644 --- a/racket/src/schemify/known.rkt +++ b/racket/src/schemify/known.rkt @@ -12,6 +12,7 @@ known-procedure/can-inline/need-imports known-procedure/can-inline/need-imports? known-procedure/can-inline/need-imports-needed known-procedure/succeeds known-procedure/succeeds? + known-procedure/pure known-procedure/pure? known-struct-type known-struct-type? known-struct-type-type known-struct-type-field-count known-struct-type-pure-constructor? known-constructor known-constructor? known-constructor-type @@ -50,14 +51,17 @@ (struct known-procedure/can-inline/need-imports (needed) ; (list (cons (cons <#f-or-index>)) ...) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/can-inline) -;; procedure that succeeds for all arguments and is functional so that it can be reordered +;; procedure that never raises an exception or otherwise captures/escapes the calling context (struct known-procedure/succeeds () #:prefab #:omit-define-syntaxes #:super struct:known-procedure) +;; procedure that accepts any arguments and is functional so that it can be reordered +(struct known-procedure/pure () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds) + (struct known-struct-type (type field-count pure-constructor?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent) ;; procedures with a known connection to a structure type: -(struct known-constructor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds) -(struct known-predicate (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds) +(struct known-constructor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure) +(struct known-predicate (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure) (struct known-accessor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) (struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) (struct known-field-accessor (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-accessor) diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index ae518647c9..edf737afb2 100644 --- a/racket/src/schemify/schemify.rkt +++ b/racket/src/schemify/schemify.rkt @@ -61,7 +61,8 @@ ;; 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? for-jitify? allow-set!-undefined? unsafe-mode? +(define (schemify-linklet lk serializable? for-jitify? allow-set!-undefined? + unsafe-mode? no-prompt? prim-knowns get-import-knowns import-keys) (define (im-int-id id) (unwrap (if (pair? id) (cadr id) id))) (define (im-ext-id id) (unwrap (if (pair? id) (car id) id))) @@ -117,7 +118,7 @@ ;; Schemify the body, collecting information about defined names: (define-values (new-body defn-info mutated) (schemify-body* bodys/constants-lifted prim-knowns imports exports - for-jitify? allow-set!-undefined? add-import! #f unsafe-mode?)) + for-jitify? allow-set!-undefined? add-import! #f unsafe-mode? no-prompt?)) (define all-grps (append grps (reverse new-grps))) (values ;; Build `lambda` with schemified body: @@ -161,16 +162,17 @@ ;; ---------------------------------------- -(define (schemify-body l prim-knowns imports exports for-cify? unsafe-mode?) +(define (schemify-body l prim-knowns imports exports for-cify? unsafe-mode? no-prompt?) (define-values (new-body defn-info mutated) (schemify-body* l prim-knowns imports exports #f #f (lambda (im ext-id index) #f) - for-cify? unsafe-mode?)) + for-cify? unsafe-mode? no-prompt?)) new-body) (define (schemify-body* l prim-knowns imports exports for-jitify? allow-set!-undefined? add-import! - for-cify? unsafe-mode?) + for-cify? unsafe-mode? no-prompt?/in) + (define no-prompt? (or no-prompt?/in for-jitify? for-cify?)) ;; Various conversion steps need information about mutated variables, ;; where "mutated" here includes visible implicit mutation, such as ;; a variable that might be used before it is defined: @@ -182,6 +184,13 @@ (find-definitions form prim-knowns knowns imports mutated unsafe-mode? #:optimize? #t)) new-knowns)) + ;; For non-exported definitions, we may need to create some variables + ;; to guard against multiple returns + (define extra-variables (make-hasheq)) + (define (add-extra-variables l) + (append (for/list ([(int-id ex) (in-hash extra-variables)]) + `(define ,(export-id ex) (make-internal-variable 'int-id))) + l)) ;; While schemifying, add calls to install exported values in to the ;; corresponding exported `variable` records, but delay those ;; installs to the end, if possible @@ -189,11 +198,18 @@ (let loop ([l l] [in-mut-l l] [accum-exprs null] [accum-ids null]) (define mut-l (update-mutated-state! l in-mut-l mutated)) (define (make-set-variables) - (for/list ([id (in-list accum-ids)] - #:when (hash-ref exports id #f)) + (for/list ([id (in-wrap-list accum-ids)] + #: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?) + (reverse es) + (for/list ([e (in-list (reverse es))]) + (make-expr-defn e)))) (cond - [(null? l) + [(null? l) + ;; Finish by making sure that all pending variables in `accum-ids` are + ;; moved into their `variable` records: (define set-vars (make-set-variables)) (cond [(null? set-vars) @@ -209,60 +225,123 @@ allow-set!-undefined? add-import! for-cify? for-jitify? - unsafe-mode?)) - (match form - [`(define-values ,ids ,rhs) - (define simple-rhs? (simple? rhs prim-knowns knowns imports mutated)) - (append - (let ([accum-exprs (if simple-rhs? - accum-exprs - (append (make-set-variables) - accum-exprs))]) - (if (or for-jitify? for-cify?) - (reverse accum-exprs) - (make-expr-defns accum-exprs))) - (cons - schemified - (let id-loop ([ids ids] [accum-exprs null] [accum-ids (if simple-rhs? accum-ids null)]) - (cond + unsafe-mode? no-prompt?)) + ;; For the case that the right-hand side won't capture a + ;; continuation or return multiple times, we can generate a + ;; simple definition: + (define (finish-definition ids) + (append + (make-expr-defns accum-exprs) + (cons + schemified + (let id-loop ([ids ids] [accum-exprs null] [accum-ids accum-ids]) + (cond [(wrap-null? ids) (loop (wrap-cdr l) mut-l accum-exprs accum-ids)] [(or (or for-jitify? for-cify?) (via-variable-mutated-state? (hash-ref mutated (unwrap (wrap-car ids)) #f))) (define id (unwrap (wrap-car ids))) (cond - [(hash-ref exports id #f) - (id-loop (wrap-cdr ids) - (cons (make-set-variable id exports knowns mutated) - accum-exprs) - accum-ids)] - [else - (id-loop (wrap-cdr ids) accum-exprs accum-ids)])] + [(hash-ref exports id #f) + (id-loop (wrap-cdr ids) + (cons (make-set-variable id exports knowns mutated) + accum-exprs) + accum-ids)] + [else + (id-loop (wrap-cdr ids) accum-exprs accum-ids)])] [else - (id-loop (wrap-cdr ids) accum-exprs (cons (unwrap (wrap-car ids)) accum-ids))]))))] - [`,_ + (id-loop (wrap-cdr ids) accum-exprs (cons (wrap-car ids) accum-ids))]))))) + ;; For the case when the right-hand side might capture a + ;; continuation or return multiple times, so we need a prompt. + ;; The `variable` records are set within the prompt, while + ;; definitions appear outside the prompt to just transfer the + ;; value into a `variable` record (if it's not one that is + ;; mutable, and therefore always access via the `variable` + ;; record): + (define (finish-wrapped-definition ids rhs) + (append + (make-expr-defns accum-exprs) + (make-expr-defns (make-set-variables)) (cond - [(simple? form prim-knowns knowns imports mutated) - (loop (wrap-cdr l) mut-l (cons schemified accum-exprs) accum-ids)] + [no-prompt? + (cons + schemified + (loop (wrap-cdr l) mut-l null ids))] [else - ;; In case `schemified` triggers an error, sync exported variables - (define set-vars (make-set-variables)) + (define expr + `(call-with-module-prompt + (lambda () ,rhs) + ',ids + ',(for/list ([id (in-list ids)]) + (variable-constance (unwrap id) knowns mutated)) + ,@(for/list ([id (in-list ids)]) + (id-to-variable (unwrap id) exports knowns mutated extra-variables)))) + (define defns + (for/list ([id (in-list ids)]) + (make-define-variable id exports knowns mutated extra-variables))) + (cons + (make-expr-defn expr) + (append defns + (loop (wrap-cdr l) mut-l null null)))]))) + ;; Dispatch on the schemified form, distinguishing definitions + ;; from expressions: + (match schemified + [`(define ,id ,rhs) + (cond + [(simple? #:pure? #f rhs prim-knowns knowns imports mutated) + (finish-definition (list id))] + [else + (finish-wrapped-definition (list id) rhs)])] + [`(define-values ,ids ,rhs) + (cond + [(simple? #:pure? #f rhs prim-knowns knowns imports mutated) + (finish-definition ids)] + [else + (finish-wrapped-definition ids rhs)])] + [`(splice . ,ls) + (loop (append ls (wrap-cdr l)) in-mut-l accum-exprs accum-ids)] + [`,_ + (match form + [`(define-values ,ids ,_) + ;; This is a rearranged `struct` form where any necessary + ;; prompt is in place already + (finish-definition ids)] + [`,_ (cond - [(null? set-vars) - (loop (wrap-cdr l) mut-l (cons schemified accum-exprs) null)] + [(simple? #:pure? #f schemified prim-knowns knowns imports mutated) + (loop (wrap-cdr l) mut-l (cons schemified accum-exprs) accum-ids)] [else - (loop (wrap-cdr l) mut-l (cons schemified (append (reverse set-vars) accum-exprs)) null)])])])]))) + ;; In case `schemified` triggers an error, sync exported variables + (define set-vars (make-set-variables)) + (define expr (if no-prompt? + schemified + `(call-with-module-prompt (lambda () ,schemified)))) + (loop (wrap-cdr l) mut-l (cons expr (append set-vars accum-exprs)) null)])])])]))) ;; Return both schemified and known-binding information, where ;; the later is used for cross-linklet optimization - (values schemified knowns mutated)) + (values (add-extra-variables schemified) knowns mutated)) -(define (make-set-variable id exports knowns mutated) +(define (make-set-variable id exports knowns mutated [extra-variables #f]) (define int-id (unwrap id)) - (define ex (hash-ref exports int-id)) - `(variable-set! ,(export-id ex) ,id ',(variable-constance int-id knowns mutated))) + (define ex-id (id-to-variable int-id exports knowns mutated extra-variables)) + `(variable-set! ,ex-id ,id ',(variable-constance int-id knowns mutated))) -(define (make-expr-defns accum-exprs) - (for/list ([expr (in-list (reverse accum-exprs))]) - `(define ,(gensym) (begin ,expr (void))))) +(define (id-to-variable int-id exports knowns mutated extra-variables) + (export-id + (or (hash-ref exports int-id #f) + (and extra-variables + (or (hash-ref extra-variables int-id #f) + (let ([ex (export (gensym int-id) int-id)]) + (hash-set! extra-variables int-id ex) + ex)))))) + +(define (make-define-variable id exports knowns mutated extra-variables) + (define int-id (unwrap id)) + (define ex (or (hash-ref exports int-id #f) + (hash-ref extra-variables int-id))) + `(define ,id (variable-ref/no-check ,(export-id ex)))) + +(define (make-expr-defn expr) + `(define ,(gensym) (begin ,expr (void)))) (define (variable-constance id knowns mutated) (cond @@ -278,7 +357,7 @@ ;; Schemify `let-values` to `let`, etc., and ;; reorganize struct bindings. (define (schemify v prim-knowns knowns mutated imports exports allow-set!-undefined? add-import! - for-cify? for-jitify? unsafe-mode?) + for-cify? for-jitify? unsafe-mode? no-prompt?) (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [v v]) (define (schemify v) (define s-v @@ -311,7 +390,12 @@ ;; make sure `struct:` isn't used too early, since we're ;; reordering it's definition with respect to some arguments ;; of `make-struct-type`: - (simple-mutated-state? (hash-ref mutated (unwrap struct:) #f))) + (simple-mutated-state? (hash-ref mutated (unwrap struct:) #f)) + ;; If any properties, need the first LHS to be non-set!ed, because that will + ;; let us reject multi-return from continuation capture in property expressions + (or no-prompt? + (null? (struct-type-info-rest sti)) + (not (set!ed-mutated-state? (hash-ref mutated (unwrap struct:s) #f))))) (define can-impersonate? (not (struct-type-info-authentic? sti))) (define raw-s? (if can-impersonate? (gensym (unwrap s?)) s?)) `(begin @@ -394,7 +478,21 @@ [`(define-values (,id) ,rhs) `(define ,id ,(schemify rhs))] [`(define-values ,ids ,rhs) - `(define-values ,ids ,(schemify rhs))] + (let loop ([rhs rhs]) + (match rhs + [`(values ,rhss ...) + (cond + [(= (length rhss) (length ids)) + `(splice ; <- result goes back to schemify, so don't schemify rhss + ,@(for/list ([id (in-list ids)] + [rhs (in-list rhss)]) + `(define-values (,id) ,rhs)))] + [else + `(define-values ,ids ,(schemify rhs))])] + [`(let-values () ,rhs) + (loop rhs)] + [`,_ + `(define-values ,ids ,(schemify rhs))]))] [`(quote ,_) v] [`(let-values () ,body) (schemify body)] diff --git a/racket/src/schemify/simple.rkt b/racket/src/schemify/simple.rkt index 340e416e95..7e4129ee0b 100644 --- a/racket/src/schemify/simple.rkt +++ b/racket/src/schemify/simple.rkt @@ -11,7 +11,8 @@ ;; Check whether an expression is simple in the sense that its order ;; of evaluation isn't detectable. This function receives both ;; schemified and non-schemified expressions. -(define (simple? e prim-knowns knowns imports mutated) +(define (simple? e prim-knowns knowns imports mutated + #:pure? [pure? #t]) (let simple? ([e e]) (match e [`(lambda . ,_) #t] @@ -34,12 +35,18 @@ (and (for/and ([rhs (in-list rhss)]) (simple? rhs)) (simple? body))] + [`(begin ,es ...) + #:guard (not pure?) + (for/and ([e (in-list es)]) + (simple? e))] [`(,proc . ,args) (let ([proc (unwrap proc)]) (and (symbol? proc) (let ([v (or (hash-ref-either knowns imports proc) (hash-ref prim-knowns proc #f))]) - (and (known-procedure/succeeds? v) + (and (if pure? + (known-procedure/pure? v) + (known-procedure/succeeds? v)) (bitwise-bit-set? (known-procedure-arity-mask v) (length args)))) (simple-mutated-state? (hash-ref mutated proc #f)) (for/and ([arg (in-list args)])