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

add #:unsafe option for #%declare

Browse Source 
Finally give in and add an option to compile a module as unsafe. This
was going to be easy, since the option already exists at the linklet
level, but it turns out that a lot of plumbing was needed to propagate
the argument, and even more to preserve unsafety with cross-module
inlining.

Macros can effectively conditoinalize their expansion in unsafe mode
by generating the pattern

 (if (variable-reference-from-unsafe? (#%variable-reference))
     <unsafe variant>
     <safe variant>)

The compiler will only keep one of the two variants, because it
promises to optimize `(variable-reference-from-unsafe?
(#%variable-reference))` to a literal boolean. The expander will still
expand both variants, however, so avoid putting code in both variants
that itself can have safety variants.
This commit is contained in:
Matthew Flatt 2020-11-10 10:11:07 -07:00
parent c85659b905
commit 1ac6c15207
41 changed files with 19255 additions and 15585 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.makefile
View File

@ -338,7 +338,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
# This branch name changes each time the pb boot files are updated:
PB_BRANCH == circa-7.9.0.4-1
PB_BRANCH == circa-7.9.0.5-1
PB_REPO = https://github.com/racket/pb
# Alternative source for Chez Scheme boot files, normally set by

12
Makefile
View File

@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
RACKET =
RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
PB_BRANCH = circa-7.9.0.4-1
PB_BRANCH = circa-7.9.0.5-1
PB_REPO = https://github.com/racket/pb
EXTRA_REPOS_BASE =
CS_CROSS_SUFFIX =
@ -306,14 +306,14 @@ maybe-fetch-pb-as-is:
echo done
fetch-pb-from:
mkdir -p racket/src/ChezScheme/boot
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.4-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.4-1:remotes/origin/circa-7.9.0.4-1 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.4-1
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.5-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.5-1:remotes/origin/circa-7.9.0.5-1 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.5-1
pb-stage:
cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.4-1
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.4-1
cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.5-1
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.5-1
cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
pb-push:
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.4-1
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.5-1
win-cs-base:
IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

4
pkgs/base/info.rkt
View File

@ -12,7 +12,9 @@
(define collection 'multi)
(define version "7.9.0.4")
;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes:
(define version "7.9.0.5")
(define deps `("racket-lib"
["racket" #:version ,version]))

22
pkgs/racket-doc/scribblings/reference/syntax.scrbl
View File

@ -17,6 +17,7 @@
(only-in compiler/cm-accomplice
register-external-module)
racket/performance-hint
racket/unsafe/ops
syntax/parse))
@(define require-eval (make-base-eval))
@ -388,7 +389,8 @@ Legal only in a @tech{module begin context}, and handled by the
@defform[(#%declare declaration-keyword ...)
#:grammar
([declaration-keyword #:cross-phase-persistent
#:empty-namespace])]{
#:empty-namespace
#:unsafe])]{
Declarations that affect run-time or reflective properties of the
module:
@ -406,6 +408,21 @@ module:
way can reduce the @tech{lexical information} that
otherwise must be preserved for the module.}
@item{@indexed-racket[#:unsafe] --- declares that the module can be
compiled without checks that could trigger
@racket[exn:fail:contract], and the resulting behavior is
unspecified for an evaluation where @racket[exn:fail:contract]
should have been raised; see also @secref["unsafe"]. For
example, a use of @racket[car] can be compiled as a use of
@racket[unsafe-car], and the behavior is unspecified is
@racket[unsafe-car] is applied to a non-pair. The
@racket[#:unsafe] declaration keyword is allowed only when the
current @tech{code inspector} is the initial one. Macros can
generate conditionally unsafe code, depending on the expansion
context, by expanding to a use of
@racket[(variable-reference-from-unsafe?
(#%variable-reference))].}
]
A @racket[#%declare] form must appear in a @tech{module
@ -413,7 +430,8 @@ context} or a @tech{module-begin context}. Each
@racket[declaration-keyword] can be declared at most once within a
@racket[module] body.
@history[#:changed "6.3" @elem{Added @racket[#:empty-namespace].}]}
@history[#:changed "6.3" @elem{Added @racket[#:empty-namespace].}
#:changed "7.9.0.5" @elem{Added @racket[#:unsafe].}]}
@;------------------------------------------------------------------------

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

@ -2717,6 +2717,17 @@ case of module-leve bindings; it doesn't cover local bindings.
(namespace-attach-module-declaration (current-namespace) ''please-attach-me-successfully (make-base-namespace))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that `#:unsafe` is allowed
(module unsafe-module-so-call-provided-carefully racket/base
(#%declare #:unsafe)
(provide unsafe-first)
(define (unsafe-first l) (car l)))
(require 'unsafe-module-so-call-provided-carefully)
(test 3 unsafe-first '(3 4 5))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure that a module with an attached instance
;; cannot be redeclared in the target namespace

15
racket/src/ChezScheme/csug/syntax.stex
View File

@ -1527,6 +1527,21 @@ rather than:
\endschemedisplay
\section{Unsafety\label{SECTSYNTAXBEGINUNSAFE}}
%----------------------------------------------------------------------------
\noskipentryheader
\formdef{begin-unsafe}{\categorysyntax}{(begin-unsafe \var{e_1} \var{e_2} \dots)}
\returns value of last \var{e}
\listlibraries
\endentryheader
\scheme{begin-unsafe} is like \scheme{begin} in an expression
position, but it sets \scheme{optimize-level} to 3 while expanding the
body expressions---which, for example, causes references to primitives
to refer to unsafe variants.
\section{Annotations\label{SECTSYNTAXANNOTATIONS}}
\index{annotations}%

2
racket/src/ChezScheme/makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point #
###############################################################################
Version=csv9.5.3.48
Version=csv9.5.3.49
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

2
racket/src/ChezScheme/s/cmacros.ss
View File

@ -357,7 +357,7 @@
;; ---------------------------------------------------------------------
;; Version and machine types:
(define-constant scheme-version #x09050330)
(define-constant scheme-version #x09050331)
(define-syntax define-machine-types
(lambda (x)

1
racket/src/ChezScheme/s/primdata.ss
View File

@ -1048,6 +1048,7 @@
(add-prefix [flags])
(alias [flags])
(annotation-options [flags])
(begin-unsafe [flags])
(case [flags])
(constructor [flags])
(critical-section [flags])

7
racket/src/ChezScheme/s/syntax.ss
View File

@ -6377,6 +6377,13 @@
(unless (source-object? src) (syntax-error src "profile subform is not a source object"))
(build-input-profile src))])))
(global-extend 'core 'begin-unsafe
(lambda (e r w ae)
(syntax-case e ()
((_ e1 e2 ...)
(parameterize ([optimize-level 3])
(chi-sequence #'(e1 e2 ...) r w no-source))))))
(global-extend 'set! 'set! '())
(global-extend 'alias 'alias '())

428
racket/src/bc/src/startup.inc
View File

@ -20737,6 +20737,7 @@ static const char *startup_source =
" $value"
" with-continuation-mark*"
" pariah"
" begin-unsafe"
" variable-set!"
" variable-ref"
" variable-ref/no-check"
@ -32571,14 +32572,15 @@ static const char *startup_source =
" root-ctx-only-if-syntax?7_0"
" serializable?12_0"
" to-correlated-linklet?14_0"
" bodys30_0"
" cctx31_0"
" mpis32_0)"
" unsafe?-box16_0"
" bodys32_0"
" cctx33_0"
" mpis34_0)"
"(begin"
" 'compile-forms"
"(let-values(((bodys_0) bodys30_0))"
"(let-values(((cctx_0) cctx31_0))"
"(let-values(((mpis_0) mpis32_0))"
"(let-values(((bodys_0) bodys32_0))"
"(let-values(((cctx_0) cctx33_0))"
"(let-values(((mpis_0) mpis34_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))"
@ -32596,6 +32598,7 @@ static const char *startup_source =
"(let-values(((module-prompt?_0) module-prompt?13_0))"
"(let-values(((to-correlated-linklet?_0) to-correlated-linklet?14_0))"
"(let-values(((optimize-linklet?_0) optimize-linklet?15_0))"
"(let-values(((unsafe?-box_0) unsafe?-box16_0))"
"(let-values()"
"(let-values(((phase_0)(compile-context-phase cctx_0)))"
"(let-values(((self_0)(compile-context-self cctx_0)))"
@ -32801,7 +32804,8 @@ static const char *startup_source =
" loop!_0)"
" bodys_0"
" phase_0"
"(find-or-create-header!_0 phase_0)))"
"(find-or-create-header!_0"
" phase_0)))"
"(void))"
"(values))))"
"(let-values(((as-required?_0)"
@ -32976,26 +32980,26 @@ static const char *startup_source =
"(let-values()"
"(cons"
"(let-values()"
"(let-values(((header57_0)"
"(let-values(((header61_0)"
" header_0)"
"((temp58_0)"
"((temp62_0)"
"(compile-context-self"
" cctx_0))"
"((phase59_0)"
"((phase63_0)"
" phase_1)"
"((binding-sym60_0)"
"((binding-sym64_0)"
" binding-sym_0)"
"((temp61_0)"
"((temp65_0)"
" #f)"
"((temp62_0)"
"((temp66_0)"
" #t))"
"(register-required-variable-use!.1"
" temp66_0"
" header61_0"
" temp62_0"
" header57_0"
" temp58_0"
" phase59_0"
" binding-sym60_0"
" temp61_0)))"
" phase63_0"
" binding-sym64_0"
" temp65_0)))"
" fold-var_1))))"
"(values"
" fold-var_2)))))"
@ -33017,14 +33021,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"
@ -33033,10 +33037,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)))"
"(if(="
"(length"
@ -33140,14 +33144,14 @@ static const char *startup_source =
" cctx_0))"
"(if(compile-context?"
" the-struct_0)"
"(let-values(((phase65_0)"
"(let-values(((phase69_0)"
" phase_1)"
"((header66_0)"
"((header70_0)"
" 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"
@ -33156,10 +33160,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)))"
" #f)))))))))))"
"(if(parsed-define-syntaxes?"
@ -33236,15 +33240,15 @@ static const char *startup_source =
" cctx_0))"
"(if(compile-context?"
" the-struct_0)"
"(let-values(((phase67_0)"
"(let-values(((phase71_0)"
"(add1"
" phase_1))"
"((header68_0)"
"((header72_0)"
" next-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"
@ -33253,10 +33257,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))))))"
"(let-values((()"
"(begin"
@ -33376,14 +33380,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"
@ -33392,10 +33396,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)))"
" gen-syms_0)))))"
"(set! saw-define-syntaxes?_0"
@ -33431,14 +33435,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"
@ -33447,10 +33451,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))))))"
"(if e_0"
"(let-values()"
@ -33473,14 +33477,14 @@ static const char *startup_source =
" cctx_0))"
"(if(compile-context?"
" the-struct_0)"
"(let-values(((phase73_0)"
"(let-values(((phase77_0)"
" phase_1)"
"((header74_0)"
"((header78_0)"
" header_0))"
"(compile-context1.1"
"(compile-context-namespace"
" the-struct_0)"
" phase73_0"
" phase77_0"
"(compile-context-self"
" the-struct_0)"
"(compile-context-module-self"
@ -33489,10 +33493,10 @@ static const char *startup_source =
" the-struct_0)"
"(compile-context-lazy-syntax-literals?"
" the-struct_0)"
" header74_0))"
" header78_0))"
"(raise-argument-error"
" 'struct-copy"
" \"compile-context?\""
" \"compile-context?\""
" the-struct_0)))"
" #f"
"(="
@ -33526,7 +33530,8 @@ static const char *startup_source =
" loop!_0)"
" bodys_0"
" phase_0"
"(find-or-create-header!_0 phase_0))"
"(find-or-create-header!_0"
" phase_0))"
"(values))))"
"(let-values(((encoded-root-expand-pos_0)"
"(if encoded-root-expand-ctx-box_0"
@ -33548,17 +33553,22 @@ static const char *startup_source =
" #f)"
" #f)))"
"(let-values(((phases-in-order_0)"
"(let-values(((temp75_0)"
"(let-values(((temp79_0)"
"(hash-keys"
" phase-to-body_0))"
"((<76_0) <))"
"(sort.1 #f #f temp75_0 <76_0))))"
"((<80_0) <))"
"(sort.1"
" #f"
" #f"
" temp79_0"
" <80_0))))"
"(let-values(((min-phase_0)"
"(if(pair? phases-in-order_0)"
"(car phases-in-order_0)"
" phase_0)))"
"(let-values(((max-phase_0)"
"(if(pair? phases-in-order_0)"
"(if(pair?"
" phases-in-order_0)"
"(car"
"(reverse$1"
" phases-in-order_0))"
@ -33571,7 +33581,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)"
@ -33761,39 +33772,45 @@ static const char *startup_source =
" 'module)"
" module-use*s_0))"
"(let-values()"
"(let-values(((body-linklet77_0)"
"(let-values(((body-linklet81_0)"
" body-linklet_0)"
"((body-imports78_0)"
"((body-imports82_0)"
" body-imports_0)"
"((body-import-instances79_0)"
"((body-import-instances83_0)"
" body-import-instances_0)"
"((get-module-linklet-info80_0)"
"((get-module-linklet-info84_0)"
" get-module-linklet-info_0)"
"((serializable?81_0)"
"((serializable?85_0)"
" serializable?_0)"
"((module-prompt?82_0)"
"((module-prompt?86_0)"
" module-prompt?_0)"
"((module-use*s83_0)"
"((module-use*s87_0)"
" module-use*s_0)"
"((optimize-linklet?84_0)"
"((optimize-linklet?88_0)"
" optimize-linklet?_0)"
"((temp85_0)"
"((temp89_0)"
"(if unsafe?-box_0"
"(unbox"
" unsafe?-box_0)"
" #f))"
"((temp90_0)"
" #f)"
"((temp86_0)"
"((temp91_0)"
"(compile-context-namespace"
" cctx_0)))"
"(compile-module-linklet.1"
" body-import-instances79_0"
" body-imports78_0"
" body-import-instances83_0"
" body-imports82_0"
" unsafe-undefined"
" get-module-linklet-info80_0"
" temp85_0"
" module-prompt?82_0"
" module-use*s83_0"
" temp86_0"
" optimize-linklet?84_0"
" serializable?81_0"
" body-linklet77_0))))))"
" get-module-linklet-info84_0"
" temp90_0"
" module-prompt?86_0"
" module-use*s87_0"
" temp91_0"
" optimize-linklet?88_0"
" serializable?85_0"
" temp89_0"
" body-linklet81_0))))))"
"(values"
" phase_1"
"(cons"
@ -34010,7 +34027,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)"
@ -34172,31 +34189,33 @@ static const char *startup_source =
"(if v_0(correlated-property e_0 'compiler-hint:cross-module-inline v_0) e_0)))))"
"(define-values"
"(compile-module-linklet.1)"
"(lambda(body-import-instances36_0"
" body-imports35_0"
" compile-linklet34_0"
" get-module-linklet-info37_0"
" load-modules?42_0"
" module-prompt?39_0"
" module-use*s40_0"
" namespace43_0"
" optimize-linklet?41_0"
" serializable?38_0"
" body-linklet54_0)"
"(lambda(body-import-instances38_0"
" body-imports37_0"
" compile-linklet36_0"
" get-module-linklet-info39_0"
" load-modules?45_0"
" module-prompt?41_0"
" module-use*s42_0"
" namespace46_0"
" optimize-linklet?43_0"
" serializable?40_0"
" unsafe?44_0"
" body-linklet58_0)"
"(begin"
" 'compile-module-linklet"
"(let-values(((body-linklet_0) body-linklet54_0))"
"(let-values(((body-linklet_0) body-linklet58_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-prompt?_0) module-prompt?39_0))"
"(let-values(((module-use*s_0) module-use*s40_0))"
"(let-values(((optimize-linklet?_0) optimize-linklet?41_0))"
"(let-values(((load-modules?_0) load-modules?42_0))"
"(let-values(((namespace_0) namespace43_0))"
"(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(((optimize-linklet?_0) optimize-linklet?43_0))"
"(let-values(((unsafe?_0) unsafe?44_0))"
"(let-values(((load-modules?_0) load-modules?45_0))"
"(let-values(((namespace_0) namespace46_0))"
"(let-values()"
"(let-values(((linklet_0 new-module-use*s_0)"
"(begin"
@ -34211,11 +34230,15 @@ static const char *startup_source =
" name_0"
" keys_0"
" getter_0"
"(let-values(((flags_0)"
"(if serializable?_0"
"(if module-prompt?_0 '(serializable use-prompt) '(serializable))"
"(if module-prompt?_0"
" '(serializable use-prompt)"
" '(serializable))"
"(if module-prompt?_0"
" '(use-prompt)"
"(if optimize-linklet?_0 '() '(quick))))))"
"(if unsafe?_0(cons 'unsafe flags_0) flags_0))))"
" body-linklet_0"
" 'module"
"(list->vector(append body-import-instances_0 module-use*s_0))"
@ -34230,7 +34253,9 @@ static const char *startup_source =
"(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(optimize-linklet?_0 load-modules?_0 ns_0 get-module-linklet-info_0 init-mu*s_0)"
@ -37910,6 +37935,7 @@ static const char *startup_source =
" #f"
" serializable?19_0"
" to-correlated-linklet?20_0"
" #f"
" temp14_0"
" cctx15_0"
" mpis16_0))))"
@ -38531,6 +38557,7 @@ static const char *startup_source =
"(root-expand-context/outer-use-site-scopes the-struct_0)"
"(root-expand-context/outer-frame-id the-struct_0)))"
" (raise-argument-error 'struct-copy \"root-expand-context/outer?\" the-struct_0)))))))))"
"(define-values(initial-code-inspector)(current-code-inspector))"
"(define-values"
"(check-require-access.1)"
"(lambda(skip-imports1_0"
@ -40694,6 +40721,7 @@ static const char *startup_source =
" \"compile-context?\""
" the-struct_0)))))"
"(let-values(((cross-phase-persistent?_0) #f))"
"(let-values(((unsafe?-box_0)(box #f)))"
"(let-values(((side-effects_0)(make-hasheqv)))"
"(let-values(((check-side-effects!_0)"
"(lambda(e_0"
@ -40733,7 +40761,7 @@ static const char *startup_source =
"(void)"
"(let-values()"
"(error"
" \"internal error: have post submodules, but not already compiled\")))"
" \"internal error: have post submodules, but not already compiled\")))"
"(register-compiled-submodules"
" modules-being-compiled_0"
" pre-submodules_0"
@ -40749,7 +40777,8 @@ static const char *startup_source =
" syntax-literals_0"
" root-ctx-pos_0)"
"(let-values(((bodys57_0) bodys_0)"
"((body-cctx58_0) body-cctx_0)"
"((body-cctx58_0)"
" body-cctx_0)"
"((mpis59_0) mpis_0)"
"((temp60_0)"
"(list"
@ -40775,15 +40804,15 @@ static const char *startup_source =
" body_0)"
"(let-values()"
"(let-values(((ok?_0"
" _72_0"
" kw73_0)"
" _73_0"
" kw74_0)"
"(let-values(((s_0)"
"(parsed-s"
" body_0)))"
"(let-values(((orig-s_0)"
" s_0))"
"(let-values(((_72_0"
" kw73_0)"
"(let-values(((_73_0"
" kw74_0)"
"(let-values(((s_1)"
"(if(syntax?$1"
" s_0)"
@ -40792,12 +40821,12 @@ static const char *startup_source =
" s_0)))"
"(if(pair?"
" s_1)"
"(let-values(((_74_0)"
"(let-values(((_75_0)"
"(let-values(((s_2)"
"(car"
" s_1)))"
" s_2))"
"((kw75_0)"
"((kw76_0)"
"(let-values(((s_2)"
"(cdr"
" s_1)))"
@ -40815,24 +40844,24 @@ static const char *startup_source =
"(let-values()"
"(raise-syntax-error$1"
" #f"
" \"bad syntax\""
" \"bad syntax\""
" orig-s_0))"
"(let-values()"
" flat-s_0)))))))"
"(values"
" _74_0"
" kw75_0))"
" _75_0"
" kw76_0))"
"(raise-syntax-error$1"
" #f"
" \"bad syntax\""
" \"bad syntax\""
" orig-s_0)))))"
"(values"
" #t"
" _72_0"
" kw73_0))))))"
" _73_0"
" kw74_0))))))"
"(begin"
"(let-values(((lst_0)"
" kw73_0))"
" kw74_0))"
"(begin"
"(if(variable-reference-from-unsafe?"
"(#%variable-reference))"
@ -40878,6 +40907,15 @@ static const char *startup_source =
"(set-box!"
" encoded-root-expand-ctx-box_0"
" #f)))"
"(void))"
"(if(eq?"
"(syntax-e$1"
" kw_0)"
" '#:unsafe)"
"(let-values()"
"(set-box!"
" unsafe?-box_0"
" #t))"
"(void))))"
"(values)))))"
"(values)))))"
@ -40893,7 +40931,8 @@ static const char *startup_source =
" #f)))"
"(let-values() #f))))"
"((temp68_0)"
"(lambda(mod-name_0 phase_0)"
"(lambda(mod-name_0"
" phase_0)"
"(let-values(((ht_0)"
"(if modules-being-compiled_0"
"(hash-ref"
@ -40911,7 +40950,9 @@ static const char *startup_source =
" serializable?_0)"
"((temp70_0) #t)"
"((to-correlated-linklet?71_0)"
" to-correlated-linklet?_0))"
" to-correlated-linklet?_0)"
"((unsafe?-box72_0)"
" unsafe?-box_0))"
"(compile-forms.1"
" temp61_0"
" temp60_0"
@ -40927,6 +40968,7 @@ static const char *startup_source =
" body-context-simple?65_0"
" serializable?69_0"
" to-correlated-linklet?71_0"
" unsafe?-box72_0"
" bodys57_0"
" body-cctx58_0"
" mpis59_0))))"
@ -41083,27 +41125,28 @@ static const char *startup_source =
"(list*"
" deserialized-syntax-vector-id"
"(if serializable?_0"
"(list deserialize-syntax-id)"
"(list"
" deserialize-syntax-id)"
" '()))"
" instance-imports)"
"(list*"
" get-syntax-literal!-id"
" '(get-encoded-root-expand-ctx))"
"(qq-append"
"(let-values(((syntax-literals76_0)"
"(let-values(((syntax-literals77_0)"
" syntax-literals_0)"
"((mpis77_0)"
"((mpis78_0)"
" mpis_0)"
"((self78_0)"
"((self79_0)"
" self_0)"
"((temp79_0)"
"((temp80_0)"
"(not"
" serializable?_0)))"
"(generate-lazy-syntax-literals!.1"
" temp79_0"
" syntax-literals76_0"
" mpis77_0"
" self78_0))"
" temp80_0"
" syntax-literals77_0"
" mpis78_0"
" self79_0))"
"(list"
"(list"
" 'define-values"
@ -41305,16 +41348,16 @@ static const char *startup_source =
"(hash-set"
" bundle_10"
" 'side-effects"
"(let-values(((temp80_0)"
"(let-values(((temp81_0)"
"(hash-keys"
" side-effects_0))"
"((<81_0)"
"((<82_0)"
" <))"
"(sort.1"
" #f"
" #f"
" temp80_0"
" <81_0)))"
" temp81_0"
" <82_0)))"
" bundle_10)))"
"(let-values(((bundle_12)"
"(if empty-result-for-module->namespace?_0"
@ -41323,8 +41366,16 @@ static const char *startup_source =
" 'module->namespace"
" 'empty)"
" bundle_11)))"
"(let-values(((bundle_13)"
"(if(unbox"
" unsafe?-box_0)"
"(hash-set"
" bundle_12"
" 'unsafe?"
" #t)"
" bundle_12)))"
"(hash->linklet-bundle"
" bundle_12))))))))))))))))"
" bundle_13)))))))))))))))))"
"(let-values(((ld_0)"
"(if(if(null?"
" pre-submodules_0)"
@ -41403,7 +41454,7 @@ static const char *startup_source =
"(map2 cdr pre-submodules_0)"
"(map2 cdr post-submodules_0)"
" #f"
" #f)))))))))))))))))))))))))"
" #f))))))))))))))))))))))))))"
"(if log-performance?(let-values()(end-performance-region))(void))))))))))))))))))"
"(define-values"
"(update-submodule-names)"
@ -41851,6 +41902,7 @@ static const char *startup_source =
"(let-values()"
"(let-values(((self_0)(decl_0 'self-mpi)))"
"(let-values(((phase-to-link-modules_0)(decl_0 'phase-to-link-modules)))"
"(let-values(((unsafe?_0)(hash-ref orig-h_0 'unsafe? #f)))"
"(let-values(((find-submodule_0)"
"(lambda(mod-name_0 phase_0)"
"(begin"
@ -41873,24 +41925,25 @@ static const char *startup_source =
"(let-values()"
"(raise-arguments-error"
" 'compiled-expression-recompile"
" \"cycle in linklet imports\"))"
" \"cycle in linklet imports\"))"
"(void))"
"(values))))"
"(let-values(((b_1)(recompiled-bundle r_0)))"
"(let-values(((linklet_0)"
"(let-values(((or-part_0)"
"(hash-ref"
"(linklet-bundle->hash b_1)"
"(linklet-bundle->hash"
" b_1)"
" phase_0"
" #f)))"
"(if or-part_0"
" or-part_0"
"(raise-arguments-error"
" 'compiled-expression-recompile"
" \"cannot find submodule at phase\""
" \"submodule\""
" \"cannot find submodule at phase\""
" \"submodule\""
" mod-name_0"
" \"phase\""
" \"phase\""
" phase_0)))))"
"(module-linklet-info2.1"
" linklet_0"
@ -41921,7 +41974,8 @@ static const char *startup_source =
"(let-values(((table_1)"
"(let-values(((table_1)"
" table_0))"
"(if(exact-integer? phase_0)"
"(if(exact-integer?"
" phase_0)"
"(let-values(((table_2)"
" table_1))"
"(let-values(((table_3)"
@ -41968,21 +42022,24 @@ static const char *startup_source =
" module-use*s_0)"
"((temp11_0)"
" #t)"
"((temp12_0)"
"((unsafe?12_0)"
" unsafe?_0)"
"((temp13_0)"
" #t)"
"((ns13_0)"
"((ns14_0)"
" ns_0))"
"(compile-module-linklet.1"
" temp6_0"
" temp5_0"
" temp4_0"
" find-submodule7_0"
" temp12_0"
" temp13_0"
" temp9_0"
" module-use*s10_0"
" ns13_0"
" ns14_0"
" temp11_0"
" temp8_0"
" unsafe?12_0"
" temp3_0))))"
"(values"
" phase_0"
@ -42085,7 +42142,9 @@ static const char *startup_source =
" phase-to-link-module-uses_0"
" mpis_0)))"
"(let-values(((data-linklet_0)"
"(1/compile-linklet(generate-module-data-linklet mpis_0) 'data)))"
"(1/compile-linklet"
"(generate-module-data-linklet mpis_0)"
" 'data)))"
"(let-values(((declaration-linklet_0)"
"(1/compile-linklet"
"(generate-module-declaration-linklet"
@ -42108,7 +42167,7 @@ static const char *startup_source =
"(recompiled1.1"
" new-bundle_0"
" phase-to-link-module-uses_0"
" self_0))))))))))))))))))))))))"
" self_0)))))))))))))))))))))))))"
"(define-values"
"(create-compiled-in-memorys-using-shared-data)"
"(lambda(tops_0 data-linklet_0 ns_0)"
@ -65281,7 +65340,7 @@ static const char *startup_source =
"(let-values(((temp59_0) #t)"
"((primitive?60_0) primitive?_0)"
"((temp61_0) #t)"
"((temp62_0)(not protected?_0))"
"((temp62_0)(if(not protected?_0)(null? protected-syms_0) #f))"
"((mpi63_0) mpi_0)"
"((temp64_0)"
"(hasheqv"
@ -81626,7 +81685,8 @@ static const char *startup_source =
"(syntax-e$1"
" kw_0)"
" '(#:cross-phase-persistent"
" #:empty-namespace))"
" #:empty-namespace"
" #:unsafe))"
"(void)"
"(let-values()"
"(raise-syntax-error$1"
@ -81646,6 +81706,22 @@ static const char *startup_source =
" exp-body_0"
" kw_0))"
"(void))"
"(if(eq?"
"(syntax-e$1"
" kw_0)"
" '#:unsafe)"
"(let-values()"
"(if(eq?"
"(current-code-inspector)"
" initial-code-inspector)"
"(void)"
"(let-values()"
"(raise-syntax-error$1"
" #f"
" \"unsafe compilation disallowed by code inspector\""
" exp-body_0"
" kw_0))))"
"(void))"
"(hash-set!"
" declared-keywords_0"
"(syntax-e$1"
@ -84853,23 +84929,25 @@ static const char *startup_source =
"((linklet-primitives18_0) linklet-primitives_0)"
"((ns19_0) ns_0)"
"((temp20_0) #t)"
"((temp21_0) #t))"
"(declare-hash-based-module!.1 ns19_0 temp20_0 null #f temp21_0 temp17_0 linklet-primitives18_0))"
"(let-values(((temp22_0) '#%linklet-expander)"
"((linklet-expander-primitives23_0) linklet-expander-primitives)"
"((ns24_0) ns_0))"
"(declare-hash-based-module!.1 ns24_0 #f null #f #f temp22_0 linklet-expander-primitives23_0))"
"(let-values(((temp25_0) '#%linklet)"
"((temp26_0)(list '#%linklet-primitive '#%linklet-expander))"
"((ns27_0) ns_0))"
"(declare-reexporting-module!.1 ns27_0 #t temp25_0 temp26_0))))"
"(let-values(((temp28_0) '#%expobs)"
"((expobs-primitives29_0) expobs-primitives)"
"((ns30_0) ns_0)"
"((temp31_0) #t))"
"(declare-hash-based-module!.1 ns30_0 #f null temp31_0 #f temp28_0 expobs-primitives29_0))"
"(let-values(((ns32_0) ns_0)"
"((temp33_0)"
"((temp21_0) #t)"
"((temp22_0) #t))"
"(declare-hash-based-module!.1 ns19_0 temp20_0 null temp22_0 temp21_0 temp17_0 linklet-primitives18_0))"
"(let-values(((temp23_0) '#%linklet-expander)"
"((linklet-expander-primitives24_0) linklet-expander-primitives)"
"((ns25_0) ns_0)"
"((temp26_0) #t))"
"(declare-hash-based-module!.1 ns25_0 #f null temp26_0 #f temp23_0 linklet-expander-primitives24_0))"
"(let-values(((temp27_0) '#%linklet)"
"((temp28_0)(list '#%linklet-primitive '#%linklet-expander))"
"((ns29_0) ns_0))"
"(declare-reexporting-module!.1 ns29_0 #t temp27_0 temp28_0))))"
"(let-values(((temp30_0) '#%expobs)"
"((expobs-primitives31_0) expobs-primitives)"
"((ns32_0) ns_0)"
"((temp33_0) #t))"
"(declare-hash-based-module!.1 ns32_0 #f null temp33_0 #f temp30_0 expobs-primitives31_0))"
"(let-values(((ns34_0) ns_0)"
"((temp35_0)"
"(let-values(((ht_0) main-primitives))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))"
@ -84903,7 +84981,7 @@ static const char *startup_source =
" for-loop_0)"
" '#hash()"
"(hash-iterate-first ht_0)))))"
"((temp34_0)"
"((temp36_0)"
"(let-values(((ht_0) read-primitives))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))"
@ -84937,7 +85015,7 @@ static const char *startup_source =
" for-loop_0)"
" '#hash()"
"(hash-iterate-first ht_0))))))"
"(declare-kernel-module!.1 temp33_0 temp34_0 ns32_0))"
"(declare-kernel-module!.1 temp35_0 temp36_0 ns34_0))"
"(begin"
"(let-values(((lst_0) runtime-instances))"
"(begin"
@ -84957,9 +85035,9 @@ static const char *startup_source =
"(let-values()"
"(begin"
"(let-values()"
"(let-values(((name35_0) name_0)"
"((ns36_0) ns_0)"
"((temp37_0)"
"(let-values(((name37_0) name_0)"
"((ns38_0) ns_0)"
"((temp39_0)"
"(let-values(((or-part_0)"
"(eq?"
" name_0"
@ -84978,12 +85056,12 @@ static const char *startup_source =
"(copy-runtime-module!.1"
" '#hasheq()"
" '#hasheq()"
" ns36_0"
" ns38_0"
" #t"
" temp37_0"
" temp39_0"
" unsafe-undefined"
" unsafe-undefined"
" name35_0)))"
" name37_0)))"
"(values)))))"
"(values)))))))"
"(if(not #f)(for-loop_0 rest_0)(values))))"
@ -84991,11 +85069,11 @@ static const char *startup_source =
" for-loop_0)"
" lst_0)))"
"(void))"
"(let-values(((temp38_0) '#%builtin)"
"((temp39_0)(list* '#%place-struct '#%utils '#%boot '#%expobs '#%linklet runtime-instances))"
"((ns40_0) ns_0)"
"((temp41_0) #f))"
"(declare-reexporting-module!.1 ns40_0 temp41_0 temp38_0 temp39_0))"
"(let-values(((temp40_0) '#%builtin)"
"((temp41_0)(list* '#%place-struct '#%utils '#%boot '#%expobs '#%linklet runtime-instances))"
"((ns42_0) ns_0)"
"((temp43_0) #f))"
"(declare-reexporting-module!.1 ns42_0 temp43_0 temp40_0 temp41_0))"
"(1/current-namespace ns_0)"
"(1/dynamic-require ''#%kernel 0)))))))"
"(call-with-values(lambda()(namespace-init!)) print-values)"

7
racket/src/cs/c/cross-serve.ss
View File

@ -34,11 +34,14 @@
(let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths
(case (integer->char cmd)
[(#\c)
[(#\c #\u)
(call-with-fasled
in
(lambda (v pred)
(compile-to-port (list `(lambda () ,v)) o #f #f #f (string->symbol target) #f pred)))]
(parameterize ([optimize-level (if (fx= cmd (char->integer #\u))
3
(optimize-level))])
(compile-to-port (list `(lambda () ,v)) o #f #f #f (string->symbol target) #f pred))))]
[(#\f)
;; Reads host fasl format, then writes target fasl format
(call-with-fasled

2
racket/src/cs/compile-file.ss
View File

@ -2,7 +2,7 @@
;; Check to make we're using a build of Chez Scheme
;; that has all the features we need.
(define-values (need-maj need-min need-sub need-dev)
(values 9 5 3 38))
(values 9 5 3 49))
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file

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

@ -222,17 +222,17 @@
;; engines/threads.
(define compile*
(case-lambda
[(e safe?)
[(e unsafe?)
(call-with-system-wind (lambda ()
(parameterize ([optimize-level (if safe?
(optimize-level)
3)])
(parameterize ([optimize-level (if unsafe?
3
(optimize-level))])
(if assembly-on?
(parameterize ([#%$assembly-output (#%current-output-port)])
(printf ";; assembly ---------------------\n")
(compile e))
(compile e)))))]
[(e) (compile* e #t)]))
[(e) (compile* e #f)]))
(define (interpret* e) ; result is not safe for space
(call-with-system-wind (lambda () (interpret e))))
(define (fasl-write* s o)
@ -248,12 +248,21 @@
(call-getting-sfd-paths
(lambda (pred)
(fasl-write s o pred 'omit-rtds)))))))
(define (compile-to-port* s o)
(define (compile-to-port* s o unsafe?)
(call-with-system-wind (lambda ()
(parameterize ([fasl-compressed compress-code?])
(parameterize ([fasl-compressed compress-code?]
[optimize-level (if unsafe?
3
(optimize-level))])
(call-getting-sfd-paths
(lambda (pred)
(compile-to-port s o #f #f #f (machine-type) #f pred 'omit-rtds)))))))
(define (expand/optimize* e unsafe?)
(call-with-system-wind (lambda ()
(parameterize ([optimize-level (if unsafe?
3
(optimize-level))])
(#%expand/optimize e)))))
(define (call-getting-sfd-paths proc)
(let ([sfd-paths '()])
@ -267,7 +276,7 @@
(define (eval/foreign e mode)
(performance-region
mode
(compile* e #f)))
(compile* e #t)))
(define primitives (make-hasheq)) ; hash of sym -> known
(define primitive-tables '()) ; list of (cons sym hash)
@ -287,34 +296,34 @@
(define (run-interpret s paths)
(interpret-linklet s paths))
(define (compile-to-proc s paths format)
(define (compile-to-proc s paths format unsafe?)
(if (eq? format 'interpret)
(run-interpret s paths)
(let ([proc (compile* s)])
(let ([proc (compile* s unsafe?)])
(if (null? paths)
proc
(#%apply proc paths)))))
;; returns code bytevector and sfd-paths vector
(define (compile*-to-bytevector s)
(define (compile*-to-bytevector s unsafe?)
(let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths (compile-to-port* (list `(lambda () ,s)) o)])
(let ([sfd-paths (compile-to-port* (list `(lambda () ,s)) o unsafe?)])
(values (get) sfd-paths))))
;; returns code bytevector and sfd-paths vector
(define (compile-to-bytevector s format)
(define (compile-to-bytevector s format unsafe?)
(cond
[(eq? format 'interpret)
(let-values ([(o get) (open-bytevector-output-port)])
(let ([sfd-paths (fasl-write-code* s o)])
(values (get) sfd-paths)))]
[else (compile*-to-bytevector s)]))
[else (compile*-to-bytevector s unsafe?)]))
;; returns code bytevector and sfd-paths vector
(define (cross-compile-to-bytevector machine s format)
(define (cross-compile-to-bytevector machine s format unsafe?)
(cond
[(eq? format 'interpret) (cross-fasl-to-string machine s)]
[else (cross-compile machine s)]))
[else (cross-compile machine s unsafe?)]))
(define (eval-from-bytevector bv paths sfd-paths format)
(add-performance-memory! 'faslin-code (bytevector-length bv))
@ -490,6 +499,7 @@
(define check-result (check-compile-args 'compile-linklet import-keys get-import options))
(define serializable? (#%memq 'serializable options))
(define use-prompt? (#%memq 'use-prompt options))
(define unsafe? (and (#%memq 'unsafe options) #t))
(define cross-machine (and serializable?
(let ([m (|#%app| current-compile-target-machine)])
(and (not (eq? m (machine-type)))
@ -524,7 +534,7 @@
(not (#%memq 'uninterned-literal options))
(eq? format 'interpret)
(|#%app| compile-allow-set!-undefined)
#f ;; safe mode
unsafe?
enforce-constant?
inline?
(not use-prompt?)
@ -574,10 +584,10 @@
(let ([expr (show lambda-on? "lambda" (correlated->annotation expr serializable? sfd-cache))])
(if serializable?
(let-values ([(code sfd-paths) (if cross-machine
(cross-compile cross-machine expr)
(compile*-to-bytevector expr))])
(cross-compile cross-machine expr unsafe?)
(compile*-to-bytevector expr unsafe?))])
(make-wrapped-code code sfd-paths arity-mask (extract-inferred-name expr name)))
(compile* expr)))))])))]))
(compile* expr unsafe?)))))])))]))
(define-values (paths impl-lam/paths)
(if serializable?
(extract-paths-and-fasls-from-schemified-linklet impl-lam/jitified (eq? format 'compile))
@ -595,7 +605,7 @@
(when known-on?
(show "known" (hash-map exports-info (lambda (k v) (list k v)))))
(when (and cp0-on? (eq? format 'compile))
(show "cp0" (#%expand/optimize (correlated->annotation impl-lam/paths))))
(show "cp0" (expand/optimize* (correlated->annotation impl-lam/paths) unsafe?)))
(performance-region
'compile-linklet
;; Create the linklet:
@ -603,9 +613,9 @@
(let-values ([(code sfd-paths)
(if serializable?
(if cross-machine
(cross-compile-to-bytevector cross-machine impl format)
(compile-to-bytevector impl format))
(values (compile-to-proc impl paths format) '#()))])
(cross-compile-to-bytevector cross-machine impl format unsafe?)
(compile-to-bytevector impl format unsafe?))
(values (compile-to-proc impl paths format unsafe?) '#()))])
(when paths-on?
(show "source paths" sfd-paths))
(let ([lk (make-linklet code

4
racket/src/cs/linklet/cross-compile.ss
View File

@ -63,8 +63,8 @@
(cache-cross-compiler a)
(values (car bv+paths) (cdr bv+paths)))))
(define (cross-compile machine v)
(do-cross 'c machine v))
(define (cross-compile machine v unsafe?)
(do-cross (if unsafe? 'u 'c) machine v))
(define (cross-fasl-to-string machine v)
(do-cross 'f machine v))

9285
racket/src/cs/schemified/expander.scm
View File

File diff suppressed because it is too large Load Diff

1482
racket/src/cs/schemified/io.scm
View File

File diff suppressed because it is too large Load Diff

405
racket/src/cs/schemified/regexp.scm
View File

@ -2532,14 +2532,15 @@
(let ((app_0 (range:s)))
(range-invert app_0 (chytes-limit s_0))))
(values #f #f #f)))))))))))
(define range:d (lambda () (range-union null (list (cons 48 57)))))
(define range:d
(lambda () (begin-unsafe (range-union null (list (cons 48 57))))))
(define range:w
(lambda ()
(range-add
(let ((range_0
(let ((range_0 (range:d)))
(range-union range_0 (list (cons 97 122))))))
(range-union range_0 (list (cons 65 90))))
(begin-unsafe (range-union range_0 (list (cons 97 122)))))))
(begin-unsafe (range-union range_0 (list (cons 65 90)))))
95)))
(define range:s
(lambda ()
@ -2585,43 +2586,56 @@
(if (unsafe-fx< index_0 1)
#f
(let ((range_0
(range-union null (list (cons 97 122)))))
(range-union range_0 (list (cons 65 90)))))
(begin-unsafe
(range-union null (list (cons 97 122))))))
(begin-unsafe
(range-union range_0 (list (cons 65 90))))))
(if (unsafe-fx< index_0 3)
(range-union null (list (cons 65 90)))
(begin-unsafe
(range-union null (list (cons 65 90))))
(if (unsafe-fx< index_0 4)
(range-union null (list (cons 97 122)))
(begin-unsafe
(range-union null (list (cons 97 122))))
(if (unsafe-fx< index_0 5)
(range-union null (list (cons 48 57)))
(begin-unsafe
(range-union null (list (cons 48 57))))
(let ((range_0
(let ((range_0
(range-union
null
(list (cons 48 57)))))
(range-union
range_0
(list (cons 97 102))))))
(range-union
range_0
(list (cons 65 70))))))))
(begin-unsafe
(range-union
null
(list (cons 48 57))))))
(begin-unsafe
(range-union
range_0
(list (cons 97 102)))))))
(begin-unsafe
(range-union
range_0
(list (cons 65 70)))))))))
(if (unsafe-fx< index_0 9)
(if (unsafe-fx< index_0 7)
(let ((range_0
(let ((range_0
(range-union
null
(list (cons 48 57)))))
(range-union
range_0
(list (cons 97 122))))))
(range-union range_0 (list (cons 65 90))))
(begin-unsafe
(range-union
null
(list (cons 48 57))))))
(begin-unsafe
(range-union
range_0
(list (cons 97 122)))))))
(begin-unsafe
(range-union range_0 (list (cons 65 90)))))
(if (unsafe-fx< index_0 8)
(range-add
(let ((range_0
(range-union
null
(list (cons 97 122)))))
(range-union range_0 (list (cons 65 90))))
(begin-unsafe
(range-union
null
(list (cons 97 122))))))
(begin-unsafe
(range-union range_0 (list (cons 65 90)))))
95)
(range-add (range-add null 32) 9)))
(if (unsafe-fx< index_0 10)
@ -2655,8 +2669,12 @@
(range-add (range-add range_0 32) 9)
range_0))
(if (unsafe-fx< index_0 12)
(range-union null (list (cons 0 31)))
(range-union null (list (cons 0 127)))))))))))
(begin-unsafe
(range-union null (list (cons 0 31))))
(begin-unsafe
(range-union
null
(list (cons 0 127))))))))))))
(if range_0
(values #t range_0 (+ pos_0 3 (unsafe-bytes-length class_0)))
(values #f #f #f))))
@ -2698,7 +2716,8 @@
(let ((fmt_0 "missing `}` to close `\\~a{`"))
(let ((args_0 (list (integer->char p-c_0))))
(let ((fmt_1 fmt_0))
(apply regexp-error fmt_1 args_0))))
(begin-unsafe
(apply regexp-error fmt_1 args_0)))))
(if (eqv? tmp_1 '#\x7d)
(let ((app_0 (reverse$1 accum_0)))
(values app_0 (add1 pos_1)))
@ -2727,7 +2746,8 @@
integer->char
l_0))))))
(let ((fmt_1 fmt_0))
(apply regexp-error fmt_1 args_0))))
(begin-unsafe
(apply regexp-error fmt_1 args_0)))))
(if (unsafe-fx< index_0 2)
'll
(if (unsafe-fx< index_0 3) 'lu 'lt)))
@ -2800,7 +2820,8 @@
(args (raise-binding-result-arity-error 2 args))))
(let ((fmt_0 "expected `{` after `\\~a`"))
(let ((args_0 (list (integer->char p-c_0))))
(let ((fmt_1 fmt_0)) (apply regexp-error fmt_1 args_0)))))))))
(let ((fmt_1 fmt_0))
(begin-unsafe (apply regexp-error fmt_1 args_0))))))))))
(define range-add*
(lambda (range_0 c_0 config_0)
(if (not c_0)
@ -2822,7 +2843,7 @@
(define range-add-span*
(lambda (range_0 from-c_0 to-c_0 config_0)
(if (parse-config-case-sensitive? config_0)
(range-union range_0 (list (cons from-c_0 to-c_0)))
(begin-unsafe (range-union range_0 (list (cons from-c_0 to-c_0))))
(let ((end_0 (add1 to-c_0)))
(begin
(letrec*
@ -2845,11 +2866,12 @@
'eos
(chytes-ref/char s_0 pos_0))))
(if (eq? tmp_0 'eos)
(parse-error
s_0
pos_0
config_0
"missing closing square bracket in pattern")
(begin-unsafe
(parse-error
s_0
pos_0
config_0
"missing closing square bracket in pattern"))
(if (eqv? tmp_0 '#\x5e)
(call-with-values
(lambda () (parse-range s_0 (add1 pos_0) config_0))
@ -2865,11 +2887,12 @@
'eos
(chytes-ref/char s_0 pos_0))))
(if (eq? tmp_0 'eos)
(parse-error
s_0
pos_0
config_0
"missing closing square bracket in pattern")
(begin-unsafe
(parse-error
s_0
pos_0
config_0
"missing closing square bracket in pattern"))
(if (eqv? tmp_0 '#\x5d)
(let ((temp20_0 (range-add null 93)))
(let ((temp22_0 (add1 pos_0)))
@ -2891,11 +2914,12 @@
'eos
(chytes-ref/char s6_0 pos7_0))))
(if (eq? tmp_0 'eos)
(parse-error
s6_0
pos7_0
config8_0
"missing closing square bracket in pattern")
(begin-unsafe
(parse-error
s6_0
pos7_0
config8_0
"missing closing square bracket in pattern"))
(if (eqv? tmp_0 '#\x5d)
(let ((app_0 (range-add* range5_0 span-from1_0 config8_0)))
(values app_0 (add1 pos7_0)))
@ -2907,18 +2931,20 @@
(chytes-ref/char s6_0 pos2_0))))
(if (eq? tmp_1 'eos)
(let ((pos_0 (add1 pos2_0)))
(parse-error
s6_0
pos_0
config8_0
"missing closing square bracket in pattern"))
(begin-unsafe
(parse-error
s6_0
pos_0
config8_0
"missing closing square bracket in pattern")))
(if (eqv? tmp_1 '#\x5d)
(if must-span-from2_0
(parse-error
s6_0
pos7_0
config8_0
"misplaced hyphen within square brackets in pattern")
(begin-unsafe
(parse-error
s6_0
pos7_0
config8_0
"misplaced hyphen within square brackets in pattern"))
(let ((app_0
(range-add
(range-add* range5_0 span-from1_0 config8_0)
@ -2932,11 +2958,12 @@
s6_0
pos2_0
config8_0)
(parse-error
s6_0
pos7_0
config8_0
"misplaced hyphen within square brackets in pattern"))))))
(begin-unsafe
(parse-error
s6_0
pos7_0
config8_0
"misplaced hyphen within square brackets in pattern")))))))
(if (eqv? tmp_0 '#\x5c)
(if (parse-config-px? config8_0)
(let ((pos2_0 (add1 pos7_0)))
@ -3105,7 +3132,9 @@
(lambda () (parse-regexp.1 unsafe-undefined p3_0 0 config_0))
(case-lambda
((rx_0 pos_0)
(let ((app_0 (unbox (parse-config-group-number-box config_0))))
(let ((app_0
(begin-unsafe
(unbox (parse-config-group-number-box config_0)))))
(values
rx_0
app_0
@ -3299,7 +3328,8 @@
(if (eqv? tmp_0 '#\x2a) #t (eqv? tmp_0 '#\x2b)))
(let ((fmt_0 "nested `~a` in patten"))
(let ((args_0 (list (integer->char (chytes-ref$1 s_0 pos_0)))))
(let ((fmt_1 fmt_0)) (apply regexp-error fmt_1 args_0))))
(let ((fmt_1 fmt_0))
(begin-unsafe (apply regexp-error fmt_1 args_0)))))
(if (eqv? tmp_0 '#\x7b)
(if (parse-config-px? config_0)
(parse-error s_0 pos_0 config_0 "nested `{` in pattern")
@ -3349,11 +3379,12 @@
'eos
(chytes-ref/char s_0 pos_0))))
(if (eq? tmp_0 'eos)
(parse-error
s_0
pos_0
config_0
"missing closing parenthesis in pattern")
(begin-unsafe
(parse-error
s_0
pos_0
config_0
"missing closing parenthesis in pattern"))
(if (eqv? tmp_0 '#\x3f)
(let ((pos2_0 (add1 pos_0)))
(let ((tmp_1
@ -3361,30 +3392,34 @@
'eos
(chytes-ref/char s_0 pos2_0))))
(if (eq? tmp_1 'eos)
(parse-error
s_0
pos2_0
config_0
"expected `:`, `=`, `!`, `<=`, `<!`, `i`, `-i`, `m`, `-m`, `s`, or `-s` after `(?`")
(begin-unsafe
(parse-error
s_0
pos2_0
config_0
"expected `:`, `=`, `!`, `<=`, `<!`, `i`, `-i`, `m`, `-m`, `s`, or `-s` after `(?`"))
(if (eqv? tmp_1 '#\x3e)
(let ((pre-num-groups_0
(unbox (parse-config-group-number-box config_0))))
(begin-unsafe
(unbox (parse-config-group-number-box config_0)))))
(call-with-values
(lambda ()
(parse-regexp/maybe-empty s_0 (add1 pos2_0) config_0))
(case-lambda
((rx_0 pos3_0)
(let ((post-num-groups_0
(unbox
(parse-config-group-number-box config_0))))
(begin-unsafe
(unbox
(parse-config-group-number-box config_0)))))
(let ((app_0
(let ((num-n_0
(- post-num-groups_0 pre-num-groups_0)))
(rx:cut9.1
rx_0
pre-num-groups_0
num-n_0
(needs-backtrack? rx_0)))))
(begin-unsafe
(rx:cut9.1
rx_0
pre-num-groups_0
num-n_0
(needs-backtrack? rx_0))))))
(values
app_0
(check-close-paren s_0 pos3_0 config_0)))))
@ -3432,7 +3467,8 @@
(args (raise-binding-result-arity-error 2 args))))
(parse-look s_0 pos2_0 config_0)))))))
(let ((group-number_0
(unbox (parse-config-group-number-box config_0))))
(begin-unsafe
(unbox (parse-config-group-number-box config_0)))))
(call-with-values
(lambda ()
(parse-regexp/maybe-empty
@ -3442,7 +3478,7 @@
(case-lambda
((rx_0 pos2_0)
(values
(rx:group3.1 rx_0 group-number_0)
(begin-unsafe (rx:group3.1 rx_0 group-number_0))
(check-close-paren s_0 pos2_0 config_0)))
(args (raise-binding-result-arity-error 2 args))))))))))
(define parse-look
@ -3452,11 +3488,12 @@
(lambda (config_0 pre-num-groups_0)
(begin
(-
(unbox (parse-config-group-number-box config_0))
(begin-unsafe
(unbox (parse-config-group-number-box config_0)))
pre-num-groups_0))))))
(lambda (s_0 pos2_0 config_0)
(let ((pre-num-groups_0
(unbox (parse-config-group-number-box config_0))))
(begin-unsafe (unbox (parse-config-group-number-box config_0)))))
(let ((tmp_0 (integer->char (chytes-ref$1 s_0 pos2_0))))
(if (eqv? tmp_0 '#\x3d)
(call-with-values
@ -3492,11 +3529,12 @@
'eos
(chytes-ref/char s_0 pos2+_0))))
(if (eq? tmp_1 'eos)
(parse-error
s_0
pos2+_0
config_0
"expected `:`, `=`, `!`, `<=`, `<!`, `i`, `-i`, `m`, `-m`, `s`, or `-s` after `(?`")
(begin-unsafe
(parse-error
s_0
pos2+_0
config_0
"expected `:`, `=`, `!`, `<=`, `<!`, `i`, `-i`, `m`, `-m`, `s`, or `-s` after `(?`"))
(if (eqv? tmp_1 '#\x3d)
(call-with-values
(lambda ()
@ -3543,27 +3581,30 @@
app_0
(check-close-paren s_0 pos3_0 config_0))))
(args (raise-binding-result-arity-error 2 args))))
(parse-error
s_0
pos2+_0
config_0
"expected `:`, `=`, `!`, `<=`, `<!`, `i`, `-i`, `m`, `-m`, `s`, or `-s` after `(?`"))))))
(parse-error
s_0
pos2_0
config_0
"expected `:`, `=`, `!`, `<=`, `<!`, `i`, `-i`, `m`, `-m`, `s`, or `-s` after `(?`")))))))))
(begin-unsafe
(parse-error
s_0
pos2+_0
config_0
"expected `:`, `=`, `!`, `<=`, `<!`, `i`, `-i`, `m`, `-m`, `s`, or `-s` after `(?`")))))))
(begin-unsafe
(parse-error
s_0
pos2_0
config_0
"expected `:`, `=`, `!`, `<=`, `<!`, `i`, `-i`, `m`, `-m`, `s`, or `-s` after `(?`"))))))))))
(define parse-conditional
(lambda (s_0 pos_0 config_0)
(let ((tst-pre-num-groups_0
(unbox (parse-config-group-number-box config_0))))
(begin-unsafe (unbox (parse-config-group-number-box config_0)))))
(call-with-values
(lambda () (parse-test s_0 pos_0 config_0))
(case-lambda
((tst_0 pos2_0)
(let ((tst-span-num-groups_0
(-
(unbox (parse-config-group-number-box config_0))
(begin-unsafe
(unbox (parse-config-group-number-box config_0)))
tst-pre-num-groups_0)))
(call-with-values
(lambda () (parse-pces s_0 pos2_0 config_0))
@ -3574,11 +3615,12 @@
'eos
(chytes-ref/char s_0 pos3_0))))
(if (eq? tmp_0 'eos)
(parse-error
s_0
pos3_0
config_0
"missing closing parenthesis in pattern")
(begin-unsafe
(parse-error
s_0
pos3_0
config_0
"missing closing parenthesis in pattern"))
(if (eqv? tmp_0 '#\x7c)
(call-with-values
(lambda () (parse-pces s_0 (add1 pos3_0) config_0))
@ -3589,11 +3631,12 @@
'eos
(chytes-ref/char s_0 pos4_0))))
(if (eq? tmp_1 'eos)
(parse-error
s_0
pos4_0
config_0
"missing closing parenthesis in pattern")
(begin-unsafe
(parse-error
s_0
pos4_0
config_0
"missing closing parenthesis in pattern"))
(if (eqv? tmp_1 '#\x29)
(let ((app_0
(let ((app_0 (rx-sequence pces_0)))
@ -3629,11 +3672,12 @@
'eos
(chytes-ref/char s_0 pos_0))))
(if (eq? tmp_0 'eos)
(parse-error
s_0
pos_0
config_0
"missing closing parenthesis in pattern")
(begin-unsafe
(parse-error
s_0
pos_0
config_0
"missing closing parenthesis in pattern"))
(if (eqv? tmp_0 '#\x3f)
(parse-look s_0 (add1 pos_0) config_0)
(let ((c_0 (chytes-ref$1 s_0 pos_0)))
@ -3679,7 +3723,8 @@
(if (eqv? tmp_0 '#\x2b) #t (eqv? tmp_0 '#\x3f)))
(let ((fmt_0 "`~a` follows nothing in pattern"))
(let ((args_0 (list (integer->char c_0))))
(let ((fmt_1 fmt_0)) (apply regexp-error fmt_1 args_0))))
(let ((fmt_1 fmt_0))
(begin-unsafe (apply regexp-error fmt_1 args_0)))))
(if (eqv? tmp_0 '#\x7b)
(if (parse-config-px? config_0)
(parse-error s_0 pos_0 config_0 "`{` follows nothing in pattern")
@ -3693,7 +3738,7 @@
(let ((fmt_0 "unmatched `~a` in pattern"))
(let ((args_0 (list (integer->char c_0))))
(let ((fmt_1 fmt_0))
(apply regexp-error fmt_1 args_0))))
(begin-unsafe (apply regexp-error fmt_1 args_0)))))
(values c_0 (add1 pos_0)))
(if (parse-config-case-sensitive? config_0)
(values c_0 (add1 pos_0))
@ -4439,9 +4484,10 @@
(if (<= end_0 127)
(let ((app_0
(rx-range
(range-union
null
(list (cons start_1 end_0)))
(begin-unsafe
(range-union
null
(list (cons start_1 end_0))))
255)))
(rx-alts app_0 (loop_0 (cdr l_0)) 255))
(let ((app_0
@ -4457,7 +4503,7 @@
app_0
(loop_0 (cdr l_0))
255))))))))))))))
(lambda (args_0) (let ((l_0 args_0)) (loop_0 l_0)))))
(lambda (args_0) (let ((l_0 (begin-unsafe args_0))) (loop_0 l_0)))))
(define bytes-range
(lambda (start-str_0 end-str_0)
(if (equal? start-str_0 end-str_0)
@ -4467,7 +4513,8 @@
(let ((from-c_0 (unsafe-bytes-ref start-str_0 0)))
(let ((to-c_0 (unsafe-bytes-ref end-str_0 0)))
(let ((from-c_1 from-c_0))
(range-union null (list (cons from-c_1 to-c_0))))))
(begin-unsafe
(range-union null (list (cons from-c_1 to-c_0)))))))
255)
(let ((common_0
(letrec*
@ -4520,9 +4567,10 @@
(rx-sequence
(let ((app_0
(rx-range
(range-union
null
(list (cons p_0 q_0)))
(begin-unsafe
(range-union
null
(list (cons p_0 q_0))))
255)))
(cons
app_0
@ -5390,7 +5438,7 @@
(integer->char*
128
(let ((app_0 (arithmetic-shift (bitwise-and 31 (car accum_0)) 6)))
(+ app_0 (bitwise-and last-b_0 63))))
(+ app_0 (begin-unsafe (bitwise-and last-b_0 63)))))
(if (three-byte-prefix? (car accum_0))
'continue
(if (four-byte-prefix? (car accum_0))
@ -5406,9 +5454,13 @@
12)))
(let ((app_1
(arithmetic-shift
(let ((b_0 (car accum_0))) (bitwise-and b_0 63))
(let ((b_0 (car accum_0)))
(begin-unsafe (bitwise-and b_0 63)))
6)))
(+ app_0 app_1 (bitwise-and last-b_0 63)))))
(+
app_0
app_1
(begin-unsafe (bitwise-and last-b_0 63))))))
(if (if (pair? (cdr accum_0))
(four-byte-prefix? (cadr accum_0))
#f)
@ -5427,18 +5479,18 @@
(let ((app_1
(arithmetic-shift
(let ((b_0 (cadr accum_0)))
(bitwise-and b_0 63))
(begin-unsafe (bitwise-and b_0 63)))
12)))
(let ((app_2
(arithmetic-shift
(let ((b_0 (car accum_0)))
(bitwise-and b_0 63))
(begin-unsafe (bitwise-and b_0 63)))
6)))
(+
app_0
app_1
app_2
(bitwise-and last-b_0 63))))))
(begin-unsafe (bitwise-and last-b_0 63)))))))
'fail)))))))
(if (if (let ((or-part_0 (two-byte-prefix? last-b_0)))
(if or-part_0
@ -6070,11 +6122,11 @@
(if (if (bytes? s_0)
(if (< pos_0 limit_0)
(let ((v_0 (unsafe-bytes-ref s_0 pos_0)))
(eq? 1 (unsafe-bytes-ref rng_0 v_0)))
(begin-unsafe (eq? 1 (unsafe-bytes-ref rng_0 v_0))))
#f)
(if (lazy-bytes-before-end? s_0 pos_0 limit_0)
(let ((v_0 (lazy-bytes-ref s_0 pos_0)))
(eq? 1 (unsafe-bytes-ref rng_0 v_0)))
(begin-unsafe (eq? 1 (unsafe-bytes-ref rng_0 v_0))))
#f))
(|#%app|
next-m_0
@ -6092,11 +6144,11 @@
(if (if (bytes? s_0)
(if (< pos_0 limit_0)
(let ((v_0 (unsafe-bytes-ref s_0 pos_0)))
(eq? 1 (unsafe-bytes-ref rng_0 v_0)))
(begin-unsafe (eq? 1 (unsafe-bytes-ref rng_0 v_0))))
#f)
(if (lazy-bytes-before-end? s_0 pos_0 limit_0)
(let ((v_0 (lazy-bytes-ref s_0 pos_0)))
(eq? 1 (unsafe-bytes-ref rng_0 v_0)))
(begin-unsafe (eq? 1 (unsafe-bytes-ref rng_0 v_0))))
#f))
(add1 pos_0)
#f))))
@ -6117,7 +6169,8 @@
or-part_0
(not
(let ((v_0 (unsafe-bytes-ref s_0 pos_1)))
(eq? 1 (unsafe-bytes-ref rng_0 v_0))))))
(begin-unsafe
(eq? 1 (unsafe-bytes-ref rng_0 v_0)))))))
(values pos_1 n_0 1)
(loop_0 pos3_0 (add1 n_0)))))))))
(loop_0 pos_0 0)))
@ -6139,7 +6192,8 @@
or-part_1
(not
(let ((v_0 (lazy-bytes-ref s_0 pos_1)))
(eq? 1 (unsafe-bytes-ref rng_0 v_0))))))))
(begin-unsafe
(eq? 1 (unsafe-bytes-ref rng_0 v_0)))))))))
(values pos_1 n_0 1)
(let ((app_0 (+ pos_1 1))) (loop_0 app_0 (add1 n_0)))))))))
(loop_0 pos_0 0)))))))
@ -8339,15 +8393,16 @@
#f)
(loop_0 (add1 pos_1))
(let ((pos2_0
(|#%app|
matcher_0
in_0
pos_1
start-pos_0
end-pos_0
end-pos_0
state_0
null)))
(begin-unsafe
(|#%app|
matcher_0
in_0
pos_1
start-pos_0
end-pos_0
end-pos_0
state_0
null))))
(if pos2_0
(values pos_1 pos2_0)
(if start-range_0
@ -8555,11 +8610,12 @@
(unsafe-bytes-ref
in_0
i_0)))
(eq?
1
(unsafe-bytes-ref
e_0
v_0)))
(begin-unsafe
(eq?
1
(unsafe-bytes-ref
e_0
v_0))))
(let ((app_0 (add1 i_0)))
(loop_0 app_0 (cdr l_0)))
#f))))))))
@ -8578,7 +8634,7 @@
(if (bytes? in_0)
(unsafe-bytes-ref in_0 pos_0)
(lazy-bytes-ref in_0 pos_0))))
(eq? 1 (unsafe-bytes-ref start-range_0 v_0)))))
(begin-unsafe (eq? 1 (unsafe-bytes-ref start-range_0 v_0))))))
(define FAST-STRING-LEN 64)
(define fast-drive-regexp-match?/bytes
(lambda (rx_0 in_0 start-pos_0 end-pos_0)
@ -9251,23 +9307,24 @@
max-lookbehind_0)
(skip-amt_1
skip-amt_0))
(let ((len_0
(unsafe-bytes-length
prefix25_0)))
(lazy-bytes1.1
prefix25_0
len_0
port-in_0
skip-amt_1
len_0
peek?5_0
immediate-only?6_0
progress-evt7_0
out24_0
max-lookbehind_1
#f
0
max-peek_0))))))))
(begin-unsafe
(let ((len_0
(unsafe-bytes-length
prefix25_0)))
(lazy-bytes1.1
prefix25_0
len_0
port-in_0
skip-amt_1
len_0
peek?5_0
immediate-only?6_0
progress-evt7_0
out24_0
max-lookbehind_1
#f
0
max-peek_0)))))))))
(let ((end-pos_0
(if (let ((or-part_0
(eq?

22631
racket/src/cs/schemified/schemify.scm
View File

File diff suppressed because it is too large Load Diff

326
racket/src/cs/schemified/thread.scm
View File

@ -180,7 +180,11 @@
(if (null? ls_0)
#f
(if (not (pair? ls_0))
(raise-mismatch-error 'memq "not a proper list: " orig-l_0)
(begin-unsafe
(raise-mismatch-error
'memq
"not a proper list: "
orig-l_0))
(if (eq? v_0 (car ls_0)) ls_0 (loop_0 (cdr ls_0))))))))))
(loop_0 orig-l_0))))))
(define memv
@ -197,7 +201,11 @@
(if (null? ls_0)
#f
(if (not (pair? ls_0))
(raise-mismatch-error 'memv "not a proper list: " orig-l_0)
(begin-unsafe
(raise-mismatch-error
'memv
"not a proper list: "
orig-l_0))
(if (eqv? v_0 (car ls_0)) ls_0 (loop_0 (cdr ls_0))))))))))
(loop_0 orig-l_0))))))
(define member
@ -215,10 +223,11 @@
(if (null? ls_0)
#f
(if (not (pair? ls_0))
(raise-mismatch-error
'member
"not a proper list: "
orig-l_0)
(begin-unsafe
(raise-mismatch-error
'member
"not a proper list: "
orig-l_0))
(if (equal? v_0 (car ls_0))
ls_0
(loop_0 (cdr ls_0))))))))))
@ -248,10 +257,11 @@
(if (null? ls_0)
#f
(if (not (pair? ls_0))
(raise-mismatch-error
'member
"not a proper list: "
orig-l_1)
(begin-unsafe
(raise-mismatch-error
'member
"not a proper list: "
orig-l_1))
(if (|#%app| eq?_0 v_1 (car ls_0))
ls_0
(loop_0 (cdr ls_0))))))))))
@ -1883,7 +1893,8 @@
(- app_0 (current-inexact-milliseconds)))
1000.0))))
(lambda (wakeup_0)
(if (let ((t_0 (unsafe-place-local-ref cell.3$1))) (not t_0))
(if (let ((t_0 (unsafe-place-local-ref cell.3$1)))
(begin-unsafe (not t_0)))
(void)
(call-with-values
(lambda () (min-key+value (unsafe-place-local-ref cell.3$1)))
@ -1913,9 +1924,14 @@
(args (raise-binding-result-arity-error 2 args))))))
(lambda () (|#%app| host:get-wakeup-handle))
(lambda (h_0) (|#%app| host:wakeup h_0))
(lambda () (not (let ((t_0 (unsafe-place-local-ref cell.3$1))) (not t_0))))
(lambda ()
(if (not (let ((t_0 (unsafe-place-local-ref cell.3$1))) (not t_0)))
(not
(let ((t_0 (unsafe-place-local-ref cell.3$1)))
(begin-unsafe (not t_0)))))
(lambda ()
(if (not
(let ((t_0 (unsafe-place-local-ref cell.3$1)))
(begin-unsafe (not t_0))))
(call-with-values
(lambda () (min-key+value (unsafe-place-local-ref cell.3$1)))
(case-lambda
@ -4673,8 +4689,9 @@
(if (not w_0)
(set-semaphore-count! s_0 (add1 (semaphore-count s_0)))
(begin
(|#%app| (waiter-methods-resume (waiter-ref w_0)) w_0 s_0)
(if (not (queue-start s_0))
(begin-unsafe
(|#%app| (waiter-methods-resume (waiter-ref w_0)) w_0 s_0))
(if (begin-unsafe (not (queue-start s_0)))
(set-semaphore-count! s_0 0)
(void))
(if (semaphore-peek-select-waiter? w_0)
@ -4688,11 +4705,13 @@
(queue-remove-all!
s_0
(lambda (w_0)
(|#%app| (waiter-methods-resume (waiter-ref w_0)) w_0 s_0))))))
(begin-unsafe
(|#%app| (waiter-methods-resume (waiter-ref w_0)) w_0 s_0)))))))
(define semaphore-post-all
(lambda (s_0)
(begin (start-atomic) (semaphore-post-all/atomic s_0) (end-atomic))))
(define semaphore-any-waiters? (lambda (s_0) (not (not (queue-start s_0)))))
(define semaphore-any-waiters?
(lambda (s_0) (not (begin-unsafe (not (queue-start s_0))))))
(define 1/semaphore-try-wait?
(|#%name|
semaphore-try-wait?
@ -4741,14 +4760,15 @@
(lambda ()
(begin
(queue-remove-node! s_0 n_0)
(if (not (queue-start s_0))
(if (begin-unsafe (not (queue-start s_0)))
(set-semaphore-count! s_0 0)
(void))
(lambda () (unsafe-semaphore-wait s_0))))))
(|#%app|
(waiter-methods-suspend (waiter-ref w_0))
w_0
interrupt-cb_0)))))))
(begin-unsafe
(|#%app|
(waiter-methods-suspend (waiter-ref w_0))
w_0
interrupt-cb_0))))))))
(end-atomic))))))))
(define semaphore-wait/poll.1
(|#%name|
@ -4780,7 +4800,7 @@
(lambda ()
(begin
(queue-remove-node! s9_0 n_0)
(if (not (queue-start s9_0))
(if (begin-unsafe (not (queue-start s9_0)))
(set-semaphore-count! s9_0 0)
(void))))
void
@ -4957,14 +4977,16 @@
(if (not n_1)
#f
(begin (set-thread-group-chain! tg_0 (node-next n_1)) n_1)))
(begin (set-thread-group-chain! tg_0 (node-next n_0)) n_0)))))
(begin
(set-thread-group-chain! tg_0 (node-next n_0))
(begin-unsafe n_0))))))
(define thread-group-add!
(lambda (parent_0 child_0)
(let ((t_0 (thread-group-chain-start parent_0)))
(let ((was-empty?_0 (not t_0)))
(let ((n_0 child_0))
(let ((n_0 (begin-unsafe child_0)))
(begin
(let ((n_1 n_0)) (void))
(let ((n_1 n_0)) (begin-unsafe (void)))
(set-node-next! n_0 t_0)
(set-node-prev! n_0 #f)
(if t_0
@ -4984,8 +5006,9 @@
(void))))))))
(define thread-group-remove!
(lambda (parent_0 child_0)
(let ((n_0 child_0))
(let ((n_0 (begin-unsafe child_0)))
(begin
(begin-unsafe (void))
(if (node-next n_0)
(let ((app_0 (node-next n_0)))
(set-node-prev! app_0 (node-prev n_0)))
@ -5023,7 +5046,11 @@
(if (not n_0)
accum_1
(let ((app_0 (node-next n_0)))
(loop_0 app_0 (thread-group-all-threads n_0 accum_1)))))))))
(loop_0
app_0
(thread-group-all-threads
(begin-unsafe n_0)
accum_1)))))))))
(loop_0 (thread-group-chain-start parent_0) accum_0)))))
(define struct:schedule-info
(make-record-type-descriptor* 'schedule-info #f #f #f #f 2 3))
@ -5158,7 +5185,11 @@
(let ((exts_0 (schedule-info-exts sched-info_0)))
(set-schedule-info-exts!
sched-info_0
(|#%app| (sandman-do-merge-timeout the-sandman) exts_0 timeout-at_0)))))
(begin-unsafe
(|#%app|
(sandman-do-merge-timeout the-sandman)
exts_0
timeout-at_0))))))
(define schedule-info-did-work!
(lambda (sched-info_0) (set-schedule-info-did-work?! sched-info_0 #t)))
(define reference-sink
@ -5672,11 +5703,12 @@
(set-custodian-parent-reference! c_0 cref_0)
(if cref_0
(void)
(raise-arguments-error
'make-custodian
"the custodian has been shut down"
"custodian"
parent_0))
(begin-unsafe
(raise-arguments-error
'make-custodian
"the custodian has been shut down"
"custodian"
parent_0)))
(|#%app|
host:will-register
(unsafe-place-local-ref cell.1$7)
@ -6402,11 +6434,12 @@
(if (let ((temp76_0 procz1))
(do-custodian-register.1 #f #t #f #t c_0 b_0 temp76_0))
(void)
(raise-arguments-error
'make-custodian-box
"the custodian has been shut down"
"custodian"
c_0))
(begin-unsafe
(raise-arguments-error
'make-custodian-box
"the custodian has been shut down"
"custodian"
c_0)))
b_0))))))))
(define 1/custodian-box-value
(|#%name|
@ -7182,11 +7215,12 @@
(thread-group-add! p_0 t_0)
void)
(lambda ()
(raise-arguments-error
who10_0
"the custodian has been shut down"
"custodian"
c_0))))
(begin-unsafe
(raise-arguments-error
who10_0
"the custodian has been shut down"
"custodian"
c_0)))))
(end-atomic))))
t_0))))))))))
(define make-thread
@ -7364,7 +7398,7 @@
(void))
(engine-block))
(void))
(|#%app| 1/check-for-break))))))))
(begin-unsafe (|#%app| 1/check-for-break)))))))))
(define do-kill-thread
(lambda (t_0) (if (1/thread-dead? t_0) (void) (thread-dead! t_0))))
(define remove-thread-custodian
@ -7428,7 +7462,7 @@
(void)
(set-thread-kill-callbacks! t_0 null))))
(define check-for-break-after-kill (lambda () (|#%app| 1/check-for-break)))
(define effect_1887
(define effect_2294
(begin
(void
(let ((proc_0
@ -7442,9 +7476,9 @@
(null? (thread-custodian-references t_0))))
(engine-block)
(void))
(|#%app| 1/check-for-break))
(begin-unsafe (|#%app| 1/check-for-break)))
(void))))))
(set! post-shutdown-action proc_0)))
(begin-unsafe (set! post-shutdown-action proc_0))))
(void)))
(define 1/thread-wait
(|#%name|
@ -7551,12 +7585,14 @@
(if sleeping_0
(begin
(set-thread-sleeping! t_0 #f)
(|#%app| (sandman-do-remove-thread! the-sandman) t_0 sleeping_0))
(begin-unsafe
(|#%app| (sandman-do-remove-thread! the-sandman) t_0 sleeping_0)))
(void)))))
(define add-to-sleeping-threads!
(lambda (t_0 ext-events_0)
(let ((sleeping_0
(|#%app| (sandman-do-add-thread! the-sandman) t_0 ext-events_0)))
(begin-unsafe
(|#%app| (sandman-do-add-thread! the-sandman) t_0 ext-events_0))))
(set-thread-sleeping! t_0 sleeping_0))))
(define force-atomic-timeout-callback void)
(define set-force-atomic-timeout-callback!
@ -7573,7 +7609,8 @@
(if timeout-at_0
(add-to-sleeping-threads!
t_0
(|#%app| (sandman-do-merge-timeout the-sandman) #f timeout-at_0))
(begin-unsafe
(|#%app| (sandman-do-merge-timeout the-sandman) #f timeout-at_0)))
(void))
(if (eq? t_0 (current-thread/in-atomic))
(|#%app| thread-did-work!)
@ -7689,11 +7726,12 @@
(if (if (1/custodian? benefactor14_0)
(1/custodian-shut-down? benefactor14_0)
#f)
(raise-arguments-error
'thread-resume
"the custodian has been shut down"
"custodian"
benefactor14_0)
(begin-unsafe
(raise-arguments-error
'thread-resume
"the custodian has been shut down"
"custodian"
benefactor14_0))
(void))
(start-atomic)
(begin0
@ -8391,12 +8429,14 @@
(define dequeue-mail!
(lambda (thd_0)
(let ((mbx_0 (thread-mailbox thd_0)))
(if (not (queue-start mbx_0))
(if (begin-unsafe (not (queue-start mbx_0)))
(internal-error "No Mail!\n")
(queue-remove! mbx_0)))))
(define is-mail?
(lambda (thd_0)
(not (let ((q_0 (thread-mailbox thd_0))) (not (queue-start q_0))))))
(not
(let ((q_0 (thread-mailbox thd_0)))
(begin-unsafe (not (queue-start q_0)))))))
(define push-mail!
(lambda (thd_0 v_0) (queue-add-front! (thread-mailbox thd_0) v_0)))
(define 1/thread-send
@ -8439,7 +8479,8 @@
(begin0
(if (not (1/thread-dead? thd24_0))
(begin
(queue-add! (thread-mailbox thd24_0) v25_0)
(begin-unsafe
(queue-add! (thread-mailbox thd24_0) v25_0))
(let ((wakeup_0 (thread-mailbox-wakeup thd24_0)))
(begin
(set-thread-mailbox-wakeup! thd24_0 void)
@ -8503,7 +8544,8 @@
(begin0
(let ((t_0 (current-thread/in-atomic)))
(for-each_2380
(lambda (msg_0) (queue-add-front! (thread-mailbox t_0) msg_0))
(lambda (msg_0)
(begin-unsafe (queue-add-front! (thread-mailbox t_0) msg_0)))
lst_0))
(end-atomic)))))))
(define struct:thread-receiver-evt
@ -8602,7 +8644,7 @@
(custodian-check-immediate-limit (car mrefs_0) n_0)))
(void))))))
(void)))
(define effect_2553
(define effect_2829
(begin
(void
(let ((thread-engine_0
@ -8613,7 +8655,7 @@
(if (not (eq? e_0 'running)) e_0 #f)
#f))
#f))))
(set! thread-engine-for-roots thread-engine_0)))
(begin-unsafe (set! thread-engine-for-roots thread-engine_0))))
(void)))
(define struct:channel (make-record-type-descriptor* 'channel #f #f #f #f 2 3))
(define effect_1902
@ -8868,17 +8910,19 @@
(begin
(queue-remove-node! gq_0 n_0)
(lambda () (receive_0 b_0 ch_0))))))
(|#%app|
(waiter-methods-suspend (waiter-ref gw_0))
gw_0
interrupt-cb_0))))
(begin-unsafe
(|#%app|
(waiter-methods-suspend (waiter-ref gw_0))
gw_0
interrupt-cb_0)))))
(begin
(set-box! b_0 (cdr pw+v_0))
(let ((w_0 (car pw+v_0)))
(|#%app|
(waiter-methods-resume (waiter-ref w_0))
w_0
(void)))
(begin-unsafe
(|#%app|
(waiter-methods-resume (waiter-ref w_0))
w_0
(void))))
void))))
(end-atomic)))))))))
(lambda (ch_0)
@ -8896,7 +8940,8 @@
(if pw+v_0
(begin
(let ((w_0 (car pw+v_0)))
(|#%app| (waiter-methods-resume (waiter-ref w_0)) w_0 (void)))
(begin-unsafe
(|#%app| (waiter-methods-resume (waiter-ref w_0)) w_0 (void))))
(values (list (cdr pw+v_0)) #f))
(if (poll-ctx-poll? poll-ctx_0)
(values #f ch_0)
@ -8923,10 +8968,11 @@
(if pw+v_1
(begin
(let ((w_0 (car pw+v_1)))
(|#%app|
(waiter-methods-resume (waiter-ref w_0))
w_0
(void)))
(begin-unsafe
(|#%app|
(waiter-methods-resume (waiter-ref w_0))
w_0
(void))))
(set-box! b_0 (cdr pw+v_1))
(values #t #t))
(begin
@ -8954,17 +9000,19 @@
(begin
(queue-remove-node! pq_0 n_0)
(lambda () (channel-put ch_0 v_0))))))
(|#%app|
(waiter-methods-suspend (waiter-ref pw_0))
pw_0
interrupt-cb_0))))
(begin-unsafe
(|#%app|
(waiter-methods-suspend (waiter-ref pw_0))
pw_0
interrupt-cb_0)))))
(begin
(set-box! (cdr gw+b_0) v_0)
(let ((w_0 (car gw+b_0)))
(|#%app|
(waiter-methods-resume (waiter-ref w_0))
w_0
v_0))
(begin-unsafe
(|#%app|
(waiter-methods-resume (waiter-ref w_0))
w_0
v_0)))
void))))
(end-atomic))))))))
(define channel-put/poll
@ -8975,7 +9023,8 @@
(begin
(set-box! (cdr gw+b_0) v_0)
(let ((w_0 (car gw+b_0)))
(|#%app| (waiter-methods-resume (waiter-ref w_0)) w_0 v_0))
(begin-unsafe
(|#%app| (waiter-methods-resume (waiter-ref w_0)) w_0 v_0)))
(values (list self_0) #f))
(if (poll-ctx-poll? poll-ctx_0)
(values #f self_0)
@ -9000,10 +9049,11 @@
(begin
(set-box! (cdr gw+b_1) v_0)
(let ((w_0 (car gw+b_1)))
(|#%app|
(waiter-methods-resume (waiter-ref w_0))
w_0
v_0))
(begin-unsafe
(|#%app|
(waiter-methods-resume (waiter-ref w_0))
w_0
v_0)))
(values self_0 #t))
(begin
(set! n_0 (queue-add! pq_0 (cons pw_0 v_0)))
@ -9853,7 +9903,8 @@
(define make-syncer
(lambda (evt_0 wraps_0 prev_0)
(syncer2.1 evt_0 wraps_0 null #f #f null #f prev_0 #f)))
(define none-syncer (syncer2.1 #f null null #f #f null #f #f #f))
(define none-syncer
(begin-unsafe (syncer2.1 #f null null #f #f null #f #f #f)))
(define make-syncing.1
(|#%name|
make-syncing
@ -9861,7 +9912,7 @@
(begin (syncing1.1 #f syncers5_0 void disable-break3_0 #f)))))
(define sync-atomic-poll-evt?
(lambda (evt_0)
(let ((or-part_0 (channel-put-evt*? evt_0)))
(let ((or-part_0 (begin-unsafe (channel-put-evt*? evt_0))))
(if or-part_0
or-part_0
(let ((or-part_1 (1/channel? evt_0)))
@ -10153,7 +10204,7 @@
(begin (1/semaphore-wait evt_0) evt_0)
(if (1/channel? evt_0)
(channel-get evt_0)
(if (channel-put-evt*? evt_0)
(if (begin-unsafe (channel-put-evt*? evt_0))
(begin (channel-put-do evt_0) evt_0)
(let ((temp61_0 (list evt_0)))
(do-sync.1 #f 'sync #f temp61_0))))))))
@ -10178,7 +10229,7 @@
(begin (1/semaphore-wait evt_0) evt_0)
(if (1/channel? evt_0)
(channel-get evt_0)
(if (channel-put-evt*? evt_0)
(if (begin-unsafe (channel-put-evt*? evt_0))
(begin (channel-put-do evt_0) evt_0)
(let ((temp70_0 (list evt_0)))
(do-sync.1 #f 'sync/timeout #f temp70_0)))))
@ -10212,7 +10263,8 @@
sync/timeout/enable-break
(lambda (timeout_0 . args_0)
(begin (do-sync.1 #t 'sync/timeout/enable-break timeout_0 args_0)))))
(define effect_2330 (begin (void (set! sync-on-channel 1/sync)) (void)))
(define effect_2689
(begin (void (begin-unsafe (set! sync-on-channel 1/sync))) (void)))
(define evts->syncers
(let ((evts->syncers_0
(|#%name|
@ -10246,16 +10298,17 @@
first_0
last_0)
(let ((sr_0
(syncer2.1
arg_0
wraps13_0
null
#f
#f
null
#f
last_0
#f)))
(begin-unsafe
(syncer2.1
arg_0
wraps13_0
null
#f
#f
null
#f
last_0
#f))))
(begin
(if (if (null? extended-commits_0)
(null? guarded-abandons_0)
@ -10427,7 +10480,8 @@
no-wrappers?_0))
(if (= retries_0 10)
(begin
(set-schedule-info-did-work?! sched-info_0 #t)
(begin-unsafe
(set-schedule-info-did-work?! sched-info_0 #t))
(end-atomic)
(loop_0 (syncer-next sr_0) 0 #f #f))
(if (let ((app_0 nested-sync-evt?))
@ -11401,11 +11455,11 @@
(define any-idle-waiters?
(lambda ()
(let ((s_0 (unsafe-place-local-ref cell.1$5)))
(not (not (queue-start s_0))))))
(begin-unsafe (not (begin-unsafe (not (queue-start s_0))))))))
(define post-idle
(lambda ()
(if (let ((s_0 (unsafe-place-local-ref cell.1$5)))
(not (not (queue-start s_0))))
(begin-unsafe (not (begin-unsafe (not (queue-start s_0))))))
(begin (semaphore-post/atomic (unsafe-place-local-ref cell.1$5)) #t)
#f)))
(define init-system-idle-evt!
@ -11728,7 +11782,7 @@
(void)
(loop_0))))))))
(loop_0)))
(if (|#%app| logging-future-events?)
(if (begin-unsafe (|#%app| logging-future-events?))
(begin
(flush-future-log)
(let ((id_0
@ -11755,7 +11809,7 @@
(unsafe-place-local-ref cell.1$4)
new-events_0
null)
(if (|#%app| logging-future-events?)
(if (begin-unsafe (|#%app| logging-future-events?))
(begin
(let ((lst_0 (reverse$1 new-events_0)))
(begin
@ -11981,7 +12035,7 @@
(lock-release (future*-lock f4_0))
(begin
(if was-blocked?2_0
(if (|#%app| logging-future-events?)
(if (begin-unsafe (|#%app| logging-future-events?))
(begin
(let ((temp17_0 (future*-id f4_0)))
(let ((temp18_0
@ -12181,7 +12235,7 @@
(let ((temp40_0 (future*-id f_0)))
(log-future.1 #f #f 'touch-resume temp40_0))
(1/touch f_0)))
(if (future*? s_0)
(if (begin-unsafe (future*? s_0))
(if (current-future$1)
(dependent-on-future f_0)
(begin
@ -12854,8 +12908,10 @@
(begin
(set! wakeup-this-place wakeup_0)
(set! ensure-place-wakeup-handle ensure_0))))
(define effect_2150
(begin (void (set! future-block-for-atomic future-block)) (void)))
(define effect_1869
(begin
(void (begin-unsafe (set! future-block-for-atomic future-block)))
(void)))
(define effect_2841
(begin
(void
@ -12878,7 +12934,7 @@
(make-another-initial-thread-group)
(set-root-custodian! c_0)
(init-system-idle-evt!)
(init-future-logging-place!)
(begin-unsafe (init-future-logging-place!))
(init-schedule-counters!)
(init-sync-place!)
(call-in-new-main-thread thunk_0))))
@ -13075,7 +13131,8 @@
(begin
(if t_0 (thread-reschedule! t_0) (void))
(set! did?_0 #t)))))
(|#%app| (sandman-do-poll the-sandman) thread-wakeup_0))
(begin-unsafe
(|#%app| (sandman-do-poll the-sandman) thread-wakeup_0)))
(if did?_0 (thread-did-work!) (void))
did?_0))))
(define run-callbacks-in-engine
@ -13158,17 +13215,18 @@
(schedule-info-exts
sched-info_0)
#f)))
(|#%app|
(sandman-do-merge-external-event-sets
the-sandman)
exts_0
t-exts_0)))))
(begin-unsafe
(|#%app|
(sandman-do-merge-external-event-sets
the-sandman)
exts_0
t-exts_0))))))
(values exts_1))))
(for-loop_0 exts_1 rest_0))))
exts_0))))))
(for-loop_0 sleeping-exts_0 ts_0)))))
(begin
(|#%app| (sandman-do-sleep the-sandman) exts_0)
(begin-unsafe (|#%app| (sandman-do-sleep the-sandman) exts_0))
(thread-did-work!)))))))
(define try-post-idle
(lambda () (if (post-idle) (begin (thread-did-work!) #t) #f)))
@ -13194,7 +13252,7 @@
(begin0
(unsafe-place-local-ref cell.4)
(unsafe-place-local-set! cell.4 cb_0))))
(define effect_2555
(define effect_2769
(begin
(void
(let ((proc_0
@ -13202,7 +13260,7 @@
(if (unsafe-place-local-ref cell.4)
(begin (|#%app| (unsafe-place-local-ref cell.4) #t) #t)
#f))))
(set! force-atomic-timeout-callback proc_0)))
(begin-unsafe (set! force-atomic-timeout-callback proc_0))))
(void)))
(define check-place-activity void)
(define set-check-place-activity!
@ -14350,11 +14408,12 @@
(begin
(end-atomic)
(let ((c_0 (1/current-custodian)))
(raise-arguments-error
'dynamic-place
"the custodian has been shut down"
"custodian"
c_0))))
(begin-unsafe
(raise-arguments-error
'dynamic-place
"the custodian has been shut down"
"custodian"
c_0)))))
(begin
(set-place-custodian-ref!
new-place_0
@ -14620,8 +14679,8 @@
(begin
(set-box! (place-activity-canary p_0) #t)
(let ((h_0 (place-wakeup-handle p_0)))
(|#%app| (sandman-do-wakeup the-sandman) h_0)))))
(define effect_2845
(begin-unsafe (|#%app| (sandman-do-wakeup the-sandman) h_0))))))
(define effect_2163
(begin
(void
(let ((proc_0
@ -14698,7 +14757,7 @@
#f))
(void))))))))
(void))))))
(set! check-place-activity proc_0)))
(begin-unsafe (set! check-place-activity proc_0))))
(void)))
(define do-place-kill
(lambda (p_0)
@ -14811,7 +14870,8 @@
(if result_0
(void)
(begin
(|#%app| (sandman-do-sleep the-sandman) #f)
(begin-unsafe
(|#%app| (sandman-do-sleep the-sandman) #f))
(loop_0)))))))))))
(loop_0)))))
(define struct:place-done-evt
@ -15383,12 +15443,12 @@
(if (place-result pl_0)
(void)
(let ((h_0 (place-wakeup-handle pl_0)))
(|#%app| (sandman-do-wakeup the-sandman) h_0)))
(begin-unsafe (|#%app| (sandman-do-wakeup the-sandman) h_0))))
(|#%app| host:mutex-release (place-lock pl_0)))))
(define wakeup-initial-place
(lambda ()
(let ((h_0 (place-wakeup-handle initial-place)))
(|#%app| (sandman-do-wakeup the-sandman) h_0))))
(begin-unsafe (|#%app| (sandman-do-wakeup the-sandman) h_0)))))
(define make-place-ports+fds
(lambda (in_0 out_0 err_0) (values #f #f #f in_0 out_0 err_0)))
(define set-make-place-ports+fds!

3
racket/src/expander/boot/kernel.rkt
View File

@ -68,7 +68,8 @@
(make-module #:cross-phase-persistent? #t
#:primitive? primitive?
#:predefined? #t
#:no-protected? (not protected?)
#:no-protected? (and (not protected?)
(null? protected-syms))
#:self mpi
#:provides
(hasheqv 0 (for/hash ([sym (in-hash-keys ht)])

1
racket/src/expander/compile/built-in-symbol.rkt
View File

@ -59,6 +59,7 @@
$value
with-continuation-mark*
pariah
begin-unsafe
variable-set!
variable-ref
variable-ref/no-check

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

@ -48,7 +48,8 @@
#:serializable? [serializable? #t]
#:module-prompt? [module-prompt? #f]
#:to-correlated-linklet? [to-correlated-linklet? #f]
#:optimize-linklet? [optimize-linklet? #t])
#:optimize-linklet? [optimize-linklet? #t]
#:unsafe?-box [unsafe?-box #f])
(define phase (compile-context-phase cctx))
(define self (compile-context-self cctx))
@ -280,6 +281,7 @@
#:module-prompt? module-prompt?
#:module-use*s module-use*s
#:optimize-linklet? optimize-linklet?
#:unsafe? (and unsafe?-box (unbox unsafe?-box))
#:load-modules? #f
#:namespace (compile-context-namespace cctx))]))
(values phase (cons linklet new-module-use*s))))
@ -400,21 +402,25 @@
#:module-prompt? module-prompt?
#:module-use*s module-use*s
#:optimize-linklet? optimize-linklet?
#:unsafe? unsafe?
#:load-modules? load-modules?
#:namespace namespace)
(define-values (linklet new-module-use*s)
(performance-region
['compile '_ 'linklet]
((lambda (l name keys getter)
(compile-linklet l name keys getter (if serializable?
(if module-prompt?
'(serializable use-prompt)
'(serializable))
(if module-prompt?
'(use-prompt)
(if optimize-linklet?
'()
'(quick))))))
(compile-linklet l name keys getter (let ([flags (if serializable?
(if module-prompt?
'(serializable use-prompt)
'(serializable))
(if module-prompt?
'(use-prompt)
(if optimize-linklet?
'()
'(quick))))])
(if unsafe?
(cons 'unsafe flags)
flags))))
body-linklet
'module
;; Support for cross-module optimization starts with a vector

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

@ -116,6 +116,7 @@
[lazy-syntax-literals? #t]))
(define cross-phase-persistent? #f)
(define unsafe?-box (box #f))
;; Callback to track phases that have side effects
(define side-effects (make-hasheqv))
@ -163,7 +164,9 @@
(set! cross-phase-persistent? #t))
(when (eq? (syntax-e kw) '#:empty-namespace)
(set! empty-result-for-module->namespace? #t)
(set-box! encoded-root-expand-ctx-box #f)))
(set-box! encoded-root-expand-ctx-box #f))
(when (eq? (syntax-e kw) '#:unsafe)
(set-box! unsafe?-box #t)))
#f]
[else #f]))
#:get-module-linklet-info (lambda (mod-name phase)
@ -172,8 +175,9 @@
(and ht (hash-ref ht phase #f)))
#:serializable? serializable?
#:module-prompt? #t
#:to-correlated-linklet? to-correlated-linklet?))
#:to-correlated-linklet? to-correlated-linklet?
#:unsafe?-box unsafe?-box))
(when modules-being-compiled
;; Record this module's linklets for cross-module inlining among (sub)modules
;; that are compiled together
@ -330,6 +334,9 @@
bundle)]
[bundle (if empty-result-for-module->namespace?
(hash-set bundle 'module->namespace 'empty)
bundle)]
[bundle (if (unbox unsafe?-box)
(hash-set bundle 'unsafe? #t)
bundle)])
(hash->linklet-bundle bundle)))

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

@ -102,7 +102,7 @@
;; as the mpis and link modules, then use that data for cross-module
;; optimization while recompiling the per-phase body units, and then
;; regenerate the data linklets because optimization can add new
;; linklet import.s
;; linklet imports.
(define orig-h (linklet-bundle->hash b))
;; Force compilation of linklets that are not the module body:
@ -140,6 +140,8 @@
(define self (decl 'self-mpi))
(define phase-to-link-modules (decl 'phase-to-link-modules))
(define unsafe? (hash-ref orig-h 'unsafe? #f))
(define (find-submodule mod-name phase)
;; If `mod-name` refers to a submodule in the same linklet directory,
;; then we need to force that one to be recompiled and then return it.
@ -189,6 +191,7 @@
#:module-prompt? #t
#:module-use*s module-use*s
#:optimize-linklet? #t
#:unsafe? unsafe?
#:load-modules? #t
#:namespace ns))
(values phase (cons linklet new-module-use*s))))

2
racket/src/expander/eval/module.rkt
View File

@ -77,7 +77,7 @@
(define min-phase (hash-ref h 'min-phase 0))
(define max-phase (hash-ref h 'max-phase 0))
(define language-info (hash-ref h 'language-info #f))
;; Evaluate linklets, so that they're JITted just once (on demand).
;; Also, filter the bundle hash to just the phase-specific linklets, so that
;; we don't retain other info --- especially the syntax-literals linklet.

5
racket/src/expander/eval/protect.rkt
View File

@ -20,9 +20,12 @@
;; case, a `compiled-in-memory` record holds extra-inspector
;; information that is propagated to here.
(provide check-require-access
(provide initial-code-inspector
check-require-access
check-single-require-access)
(define initial-code-inspector (current-code-inspector))
(define (check-require-access linklet #:skip-imports skip-num-imports
import-module-uses import-module-instances insp
extra-inspector ; from declaration time

6
racket/src/expander/expand/module.rkt
View File

@ -16,6 +16,7 @@
"../namespace/namespace.rkt"
"../namespace/module.rkt"
"../syntax/binding.rkt"
"../eval/protect.rkt"
"dup-check.rkt"
"free-id-set.rkt"
"stop-ids.rkt"
@ -887,10 +888,13 @@
(for ([kw (in-list (m 'kw))])
(unless (keyword? (syntax-e kw))
(raise-syntax-error #f "expected a keyword" exp-body kw))
(unless (memq (syntax-e kw) '(#:cross-phase-persistent #:empty-namespace))
(unless (memq (syntax-e kw) '(#:cross-phase-persistent #:empty-namespace #:unsafe))
(raise-syntax-error #f "not an allowed declaration keyword" exp-body kw))
(when (hash-ref declared-keywords (syntax-e kw) #f)
(raise-syntax-error #f "keyword declared multiple times" exp-body kw))
(when (eq? (syntax-e kw) '#:unsafe)
(unless (eq? (current-code-inspector) initial-code-inspector)
(raise-syntax-error #f "unsafe compilation disallowed by code inspector" exp-body kw)))
(hash-set! declared-keywords (syntax-e kw) kw))
(define parsed-body (parsed-#%declare exp-body))
(cons (if (expand-context-to-parsed? partial-body-ctx)

6
racket/src/expander/main.rkt
View File

@ -171,8 +171,10 @@
'variable-reference-constant?)])
(declare-hash-based-module! '#%linklet-primitive linklet-primitives #:namespace ns
#:primitive? #t
#:register-builtin? #t)
(declare-hash-based-module! '#%linklet-expander linklet-expander-primitives #:namespace ns)
#:register-builtin? #t
#:protected? #t)
(declare-hash-based-module! '#%linklet-expander linklet-expander-primitives #:namespace ns
#:protected? #t)
(declare-reexporting-module! '#%linklet (list '#%linklet-primitive
'#%linklet-expander)
#:namespace ns))

14
racket/src/schemify/infer-known.rkt
View File

@ -34,7 +34,7 @@
(let ([lam (if optimize-inline?
(optimize* lam prim-knowns primitives knowns imports mutated unsafe-mode?)
lam)])
(known-procedure/can-inline arity-mask lam))
(known-procedure/can-inline arity-mask (if unsafe-mode? (add-begin-unsafe lam) lam)))
(known-procedure arity-mask))]
[(and (literal? rhs)
(not (hash-ref mutated (unwrap id) #f)))
@ -154,3 +154,15 @@
[(wrap-pair? args)
(arithmetic-shift (args-arity-mask (wrap-cdr args)) 1)]
[else -1]))
(define (add-begin-unsafe lam)
(reannotate
lam
(match lam
[`(lambda ,args . ,body)
`(lambda ,args (begin-unsafe . ,body))]
[`(case-lambda [,argss . ,bodys] ...)
`(case-lambda ,@(for/list ([args (in-list argss)]
[body (in-list bodys)])
`[,args (begin-unsafe . ,body)]))]
[`,_ lam])))

4
racket/src/schemify/inline.rkt
View File

@ -198,6 +198,8 @@
`(begin . ,(clone-body exps env mutated))]
[`(begin0 ,exps ...)
`(begin0 . ,(clone-body exps env mutated))]
[`(begin-unsafe ,exps ...)
`(begin-unsafe . ,(clone-body exps env mutated))]
[`(set! ,id ,rhs)
`(set! ,id ,(clone-expr rhs env mutated))]
[`(#%variable-reference) v]
@ -304,6 +306,8 @@
(body-needed-imports exps prim-knowns imports exports env needed)]
[`(begin0 ,exps ...)
(body-needed-imports exps prim-knowns imports exports env needed)]
[`(begin-unsafe ,exps ...)
(body-needed-imports exps prim-knowns imports exports env needed)]
[`(set! ,id ,rhs)
(define u (unwrap id))
(cond

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

@ -271,6 +271,8 @@
[`(letrec* . ,_) (compile-letrec e env stack-depth stk-i tail? mutated)]
[`(begin . ,vs)
(compile-body vs env stack-depth stk-i tail? mutated)]
[`(begin-unsafe . ,vs)
(compile-body vs env stack-depth stk-i tail? mutated)]
[`(begin0 ,e)
(compile-expr e env stack-depth stk-i tail? mutated)]
[`(begin0 ,e . ,vs)
@ -477,6 +479,8 @@
(extract-list-mutated vs mutated)]
[`(begin0 ,vs)
(extract-list-mutated vs mutated)]
[`(begin-unsafe ,vs)
(extract-list-mutated vs mutated)]
[`($value ,e)
(extract-expr-mutated e mutated)]
[`(if ,tst ,thn ,els)

4
racket/src/schemify/jitify.rkt
View File

@ -266,6 +266,8 @@
(values (reannotate v `(begin . ,new-body))
new-free
new-lifts)]
[`(begin-unsafe . ,vs)
(jitify-expr `(begin . ,vs) env mutables free lifts convert-mode name in-name)]
[`(begin0 ,v0 . ,vs)
(define-values (new-v0 v0-free v0-lifts)
(jitify-expr v0 env mutables free lifts (convert-mode-non-tail convert-mode) name in-name))
@ -650,6 +652,7 @@
[`(letrec* . ,_) (find-mutable-in-let env v accum)]
[`(begin . ,vs) (body-find-mutable env vs accum)]
[`(begin0 . ,vs) (body-find-mutable env vs accum)]
[`(begin-unsafe . ,vs) (body-find-mutable env vs accum)]
[`(if ,tst ,thn ,els)
(find-mutable env tst
(find-mutable env thn
@ -795,6 +798,7 @@
[`(letrec* . ,_) (record-sizes-in-let! v sizes)]
[`(begin . ,vs) (add1 (body-record-sizes! vs sizes))]
[`(begin0 . ,vs) (add1 (body-record-sizes! vs sizes))]
[`(begin-unsafe . ,vs) (add1 (body-record-sizes! vs sizes))]
[`(if ,tst ,thn ,els)
(+ 1
(record-sizes! tst sizes)

7
racket/src/schemify/lift.rkt
View File

@ -141,6 +141,7 @@
(lift?/seq body))]
[`(begin . ,vs) (lift?/seq vs)]
[`(begin0 . ,vs) (lift?/seq vs)]
[`(begin-unsafe . ,vs) (lift?/seq vs)]
[`(quote . ,_) #f]
[`(if ,tst ,thn ,els)
(or (lift? tst) (lift? thn) (lift? els))]
@ -308,6 +309,8 @@
(cdr new-frees+binds))]
[`(begin . ,vs)
(compute-seq-lifts! vs frees+binds lifts locals)]
[`(begin-unsafe . ,vs)
(compute-seq-lifts! vs frees+binds lifts locals)]
[`(begin0 . ,vs)
(compute-seq-lifts! vs frees+binds lifts locals)]
[`(quote . ,_) frees+binds]
@ -445,6 +448,8 @@
(find-seq-loops body lifts #hasheq() loops))]
[`(begin . ,vs)
(find-seq-loops vs lifts loop-if-tail loops)]
[`(begin-unsafe . ,vs)
(find-seq-loops vs lifts loop-if-tail loops)]
[`(begin0 ,v . ,vs)
(define new-loops (find-loops v lifts #hasheq() loops))
(if (null? vs)
@ -653,6 +658,8 @@
`[,args . ,(convert-lifted-calls-in-seq/box-mutated body args lifts frees empties)]))))]
[`(begin . ,vs)
(reannotate v `(begin . ,(convert-lifted-calls-in-seq vs lifts frees empties)))]
[`(begin-unsafe . ,vs)
(reannotate v `(begin-unsafe . ,(convert-lifted-calls-in-seq vs lifts frees empties)))]
[`(begin0 . ,vs)
(reannotate v `(begin0 . ,(convert-lifted-calls-in-seq vs lifts frees empties)))]
[`(quote . ,_) v]

2
racket/src/schemify/mutated.rkt
View File

@ -183,6 +183,8 @@
(find-mutated! body ids)]
[`(begin ,exps ...)
(find-mutated!* exps ids)]
[`(begin-unsafe ,exps ...)
(find-mutated!* exps ids)]
[`(begin0 ,exp ,exps ...)
(find-mutated! exp ids)
(find-mutated!* exps #f)]

2
racket/src/schemify/optimize.rkt
View File

@ -103,6 +103,8 @@
`(with-continuation-mark ,(optimize* key) ,(optimize* val) ,(optimize* body))]
[`(begin ,body ...)
`(begin ,@(optimize*-body body))]
[`(begin-unsafe ,body ...)
`(begin-unsafe ,@(optimize*-body body))]
[`(begin0 ,e ,body ...)
`(begin0 ,(optimize* e) ,@(optimize*-body body))]
[`(set! ,id ,rhs)

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

@ -663,6 +663,8 @@
(schemify exp wcm-state)]
[`(begin ,exps ...)
`(begin . ,(schemify-body exps wcm-state))]
[`(begin-unsafe ,exps ...)
`(begin-unsafe . ,(schemify-body exps wcm-state))]
[`(begin0 ,exp)
(schemify exp wcm-state)]
[`(begin0 ,exp ,exps ...)

4
racket/src/schemify/serialize.rkt
View File

@ -74,6 +74,8 @@
`(with-continuation-mark* ,mode ,(convert key) ,(convert val) ,(convert body))]
[`(begin ,exps ...)
`(begin . ,(convert-body exps))]
[`(begin-unsafe ,exps ...)
`(begin-unsafe . ,(convert-body exps))]
[`(begin0 ,exps ...)
`(begin0 . ,(convert-body exps))]
[`(set! ,id ,rhs)
@ -132,6 +134,8 @@
(convert-any? body))]
[`(begin ,exps ...)
(convert-any? exps)]
[`(begin-unsafe ,exps ...)
(convert-any? exps)]
[`(begin0 ,exps ...)
(convert-any? exps)]
[`(set! ,id ,rhs)

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

@ -34,6 +34,15 @@
(define (returns n)
(or (not result-arity)
(eqv? n result-arity)))
(define (simple-begin? es)
(cached
(let loop ([es es])
(cond
[(null? (cdr es))
(simple? (car es) result-arity)]
[else
(and (simple? (car es) #f)
(loop (cdr es)))]))))
(match e
[`(lambda . ,_) (returns 1)]
[`(case-lambda . ,_) (returns 1)]
@ -63,14 +72,9 @@
(simple? body result-arity)))]
[`(begin ,es ...)
#:guard (not pure?)
(cached
(let loop ([es es])
(cond
[(null? (cdr es))
(simple? (car es) result-arity)]
[else
(and (simple? (car es) #f)
(loop (cdr es)))])))]
(simple-begin? es)]
[`(begin-unsafe ,es ...)
(simple-begin? es)]
[`(begin0 ,e0 ,es ...)
(cached
(and (simple? e0 result-arity)

2
racket/src/schemify/size.rkt
View File

@ -34,6 +34,8 @@
(leftover-size els (leftover-size thn (leftover-size tst (sub1 size))))]
[`(with-continuation-mark* ,_ ,key ,val ,body)
(leftover-size body (leftover-size val (leftover-size key (sub1 size))))]
[`(begin-unsafe . ,body)
(body-leftover-size body (sub1 size))]
[`(begin0 . ,body)
(body-leftover-size body (sub1 size))]
[`(quote ,v) (if (and serializable?

2
racket/src/version/racket_version.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 9
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_W 5
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x