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

cs: prompts for module-body expressions

Browse Source 
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
This commit is contained in:
Matthew Flatt 2018-11-30 10:38:55 -07:00
parent 6f0748108c
commit 68e105c0ed
26 changed files with 734 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -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]))

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

@ -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?)]{

24
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -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.

2
racket/src/cs/convert.rkt
View File

@ -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

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

@ -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))))

2
racket/src/cs/primitive/internal.ss
View File

@ -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)])

80
racket/src/cs/primitive/kernel.ss
View File

@ -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 -2)]
[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)]
[symbol<? (known-procedure -2)]
[symbol? (known-procedure/succeeds 2)]
[symbol? (known-procedure/pure 2)]
[sync (known-procedure -1)]
[sync/enable-break (known-procedure -1)]
[sync/timeout (known-procedure -2)]
@ -933,7 +933,7 @@
[thread/suspend-to-kill (known-procedure 2)]
[thread? (known-procedure 2)]
[time-apply (known-procedure 4)]
[true-object? (known-procedure/succeeds 2)]
[true-object? (known-procedure/pure 2)]
[truncate (known-procedure 2)]
[unbox (known-procedure 2)]
[unbox* (known-procedure 2)]
@ -942,7 +942,7 @@
[unquoted-printing-string-value (known-procedure 2)]
[unquoted-printing-string? (known-procedure 2)]
[values (known-procedure -1)]
[vector (known-procedure/succeeds -1)]
[vector (known-procedure/pure -1)]
[vector->immutable-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)]

7
racket/src/cs/primitive/linklet.ss
View File

@ -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)]

176
racket/src/cs/primitive/unsafe.ss
View File

@ -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=? (known-procedure/succeeds -2)]
[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=? (known-procedure/pure -2)]
[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)]

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

@ -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)

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

@ -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

6
racket/src/expander/compile/instance.rkt
View File

@ -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

1
racket/src/expander/compile/module.rkt
View File

@ -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

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

@ -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))

16
racket/src/expander/expand/main.rkt
View File

@ -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

1
racket/src/expander/run/linklet-operation.rkt
View File

@ -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

3
racket/src/expander/run/linklet.rkt
View File

@ -99,6 +99,9 @@
[(procedure? fail-k) (fail-k)]
[else fail-k]))
(define (instance-describe-variable! i sym desc)
(void))
;; ----------------------------------------
(define undefined (gensym 'undefined))

2
racket/src/racket/src/cify-startup.rkt
View File

@ -78,6 +78,8 @@
;; for cify:
#t
;; unsafe mode:
#t
;; no prompts:
#t)))
(printf "Lift...\n")

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

@ -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)

2
racket/src/racket/src/schminc.h
View File

@ -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

4
racket/src/racket/src/schvers.h
View File

@ -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)

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

@ -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"

18
racket/src/schemify/find-definition.rkt
View File

@ -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)]))

10
racket/src/schemify/known.rkt
View File

@ -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 <sym> (cons <sym> <#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)

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

@ -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)]

11
racket/src/schemify/simple.rkt
View File

@ -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)])