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

cs: take advantage of new lifting in Chez Scheme

Browse Source 
Since Chez Scheme now performs the kind of closure conversion that
Racket does --- ensuring that a closure is not allocated if it is
bound to an identifier that is used only in application positions ---
the variant in schemify is not longer run. The hacky macro-based
lifter in the "rumble" layer can also go.

The lifting pass is still preserved in schemify, because it is still
useful to cify. It's not clear whether interpreter mode (which is used
during macro expansion for compile-time code that doesn't cross a
module boundary) is better off with or without schemify's lift, but
it's gone for now.
This commit is contained in:
Matthew Flatt 2020-12-18 14:02:15 -07:00
parent 97d9825801
commit 72d278cb84
31 changed files with 74152 additions and 88798 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.14-2
PB_BRANCH == circa-7.9.0.15-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.14-2
PB_BRANCH = circa-7.9.0.15-1
PB_REPO = https://github.com/racket/pb
EXTRA_REPOS_BASE =
CS_CROSS_SUFFIX =
@ -307,18 +307,18 @@ 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.14-2 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.14-2:remotes/origin/circa-7.9.0.14-2 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.14-2
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.15-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.15-1:remotes/origin/circa-7.9.0.15-1 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.15-1
pb-fetch:
$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)"
pb-build:
cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
pb-stage:
cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.14-2
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.14-2
cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.15-1
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.15-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.14-2
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.15-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)"

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes:
(define version "7.9.0.14")
(define version "7.9.0.15")
(define deps `("racket-lib"
["racket" #:version ,version]))

3
pkgs/racket-doc/scribblings/reference/compiler.scrbl
View File

@ -91,9 +91,6 @@ forms or adjust the way forms are displayed:
generated names, instead of abbreviations that may conflate
different symbols}
@item{@envvar-indexed{PLT_LINKLET_SHOW_PRE_LIFT} --- shows a
schemified forms before closure transformations are applied}
@item{@envvar-indexed{PLT_LINKLET_SHOW_PRE_JIT} --- shows a
schemified forms before a transformation to JIT mode, which
applies only when @envvar{PLT_CS_JIT} is set}

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.56
Version=csv9.5.3.57
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

9
racket/src/ChezScheme/mats/cp0.ms
View File

@ -3214,6 +3214,15 @@
'(begin (g) 5)
'(begin (#3%$value (g)) 5)))
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(let ([f (#2%make-wrapper-procedure (lambda (x) x) 2 'data)]) (#2%list f (f 5)))))
'(#2%list (#2%make-wrapper-procedure (lambda (x) x) 2 'data) 5))
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(let ([f (#2%make-arity-wrapper-procedure (lambda (x) x) 2 'data)]) (#2%list f (f 5)))))
'(#2%list (#2%make-arity-wrapper-procedure (lambda (x) x) 2 'data) 5))
(not
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])

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

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

16
racket/src/ChezScheme/s/cp0.ss
View File

@ -1923,7 +1923,7 @@
(define copy2
; ctxt is value, test, or app
(lambda (maybe-src id opnd ctxt sc wd name moi)
(let ([rhs (result-exp (operand-value opnd))])
(let loop ([rhs (result-exp (operand-value opnd))])
(nanopass-case (Lsrc Expr) rhs
[(case-lambda ,preinfo1 ,cl* ...)
(context-case ctxt
@ -1989,6 +1989,20 @@
true-rec
(residualize-ref maybe-src id sc))]
[else (fold-primref rhs ctxt sc wd name moi)])]
[(call ,preinfo ,pr ,e1 ,e2 ,e3)
;; inline wrapped procedure, if it's easy:
(guard (app? ctxt)
(or (eq? (primref-name pr) 'make-wrapper-procedure)
(eq? (primref-name pr) 'make-arity-wrapper-procedure))
(nanopass-case (Lsrc Expr) e2
[(quote ,d)
(and (exact? d) (integer? d)
(bitwise-bit-set? d (length (app-opnds ctxt))))]
[else #f])
(nanopass-case (Lsrc Expr) e2
[(quote ,d) #t]
[else #f]))
(loop e1)]
[else (residualize-ref maybe-src id sc)]))))
(define fold-primref

3
racket/src/cs/Makefile
View File

@ -258,8 +258,7 @@ future-demo: $(BUILDDIR)rumble.$(CSO)
future2-demo: $(BUILDDIR)rumble.$(CSO)
$(SCHEME) $(BUILDDIR)chezpart.$(CSO) $(BUILDDIR)rumble.$(CSO) demo/future2.ss
RUMBLE_SRCS = rumble/define.ss \
rumble/virtual-register.ss \
RUMBLE_SRCS = rumble/virtual-register.ss \
rumble/layout.ss \
rumble/check.ss \
rumble/syntax-rule.ss \

10
racket/src/cs/README.txt
View File

@ -132,7 +132,10 @@ Racket CS currently supports three compilation modes:
interpreter around the compiled parts).
Select this mode by setting the `PLT_CS_MACH` environment variable,
but it's currently the default.
but it's currently the default. When this mode is selected,
interpreter mode is still used for compile-time code that does not
span a module (or, more generally, for the 'quick option to
`compile-linklet` and similar functions).
When the "cs" suffix is used for build mode, compiled ".zo" files
in this mode are written to a subdirectory of "compiled" using the
@ -164,7 +167,12 @@ Racket CS currently supports three compilation modes:
* JIT mode --- The compiled form of a module is an S-expression where
individual `lambda`s are compiled on demand.
JIT mode does not perform well and probably should be discontinued.
Select this mode by setting the `PLT_CS_JIT` environment variable.
When this mode is selected, interpreter mode is still used for
compile-time code that does not span a module (or, more generally,
for the 'quick option to `compile-linklet` and similar functions).
When the "cs" suffix is used for build mode, compiled ".zo" files
in this mode are written to a "cs" subdirectory of "compiled".

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 55))
(values 9 5 3 57))
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
(error 'compile-file

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

@ -132,10 +132,7 @@
unsafe-mode?
#t ; no-prompt?
#f))) ; explicit-unnamed?
(printf "Lift...\n")
;; Lift functions to avoid closure creation:
(time
(lift-in-schemified-body body #t))))
body))
;; ----------------------------------------

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

@ -175,7 +175,6 @@
[else #f])]))
(define gensym-on? (getenv "PLT_LINKLET_SHOW_GENSYM"))
(define pre-lift-on? (getenv "PLT_LINKLET_SHOW_PRE_LIFT"))
(define pre-jit-on? (getenv "PLT_LINKLET_SHOW_PRE_JIT"))
(define lambda-on? (getenv "PLT_LINKLET_SHOW_LAMBDA"))
(define post-lambda-on? (getenv "PLT_LINKLET_SHOW_POST_LAMBDA"))
@ -187,7 +186,6 @@
(define assembly-on? (getenv "PLT_LINKLET_SHOW_ASSEMBLY"))
(define show-on? (or gensym-on?
pre-jit-on?
pre-lift-on?
post-lambda-on?
post-interp-on?
jit-demand-on?
@ -304,10 +302,17 @@
(define (run-interpret s)
(interpret-linklet s))
(define (lambda->linklet-lambda s)
;; Replace `lambda` with `$lambda/lift-barrier`, which prevents
;; the compiler from converting functions in the immediate linklet
;; body to take closure elements are arguments; at the level of a
;; linklet, it's better to create all of the closures on instantiation
(cons '$lambda/lift-barrier (cdr s)))
(define (compile-to-proc s format unsafe?)
(if (eq? format 'interpret)
(run-interpret s)
(compile* s unsafe?)))
(compile* (lambda->linklet-lambda s) unsafe?)))
;; returns code bytevector and literals vector
(define (compile*-to-bytevector s quoteds unsafe?)
@ -322,13 +327,13 @@
(let-values ([(o get) (open-bytevector-output-port)])
(let ([literals (fasl-write-code* s quoteds o)])
(values (get) literals)))]
[else (compile*-to-bytevector s quoteds unsafe?)]))
[else (compile*-to-bytevector (lambda->linklet-lambda s) quoteds unsafe?)]))
;; returns code bytevector and literals vector
(define (cross-compile-to-bytevector machine s quoteds format unsafe?)
(cond
[(eq? format 'interpret) (cross-fasl-to-string machine s quoteds)]
[else (cross-compile machine s quoteds unsafe?)]))
[else (cross-compile machine (lambda->linklet-lambda s) quoteds unsafe?)]))
(define (eval-from-bytevector bv literals format)
(add-performance-memory! 'faslin-code (bytevector-length bv))
@ -528,6 +533,7 @@
'schemify
(define jitify-mode?
(and (not just-expand?)
(not quick-mode?)
(or (eq? linklet-compilation-mode 'jit)
(and (eq? linklet-compilation-mode 'mach)
(linklet-bigger-than? c linklet-compilation-limit serializable?)
@ -558,19 +564,15 @@
(lambda (key) (lookup-linklet-or-instance get-import key))
(lambda (key) (values #f #f #f)))
import-keys))
(define impl-lam/lifts
(lift-in-schemified-linklet (show pre-lift-on? "pre-lift" impl-lam)
;; preserve loop forms?
(not (eq? linklet-compilation-mode 'interp))))
(define impl-lam/jitified
(cond
[(not jitify-mode?) impl-lam/lifts]
[(not jitify-mode?) impl-lam]
[else
(performance-region
'jitify
(jitify-schemified-linklet (case linklet-compilation-mode
[(jit) (show pre-jit-on? "pre-jitified" impl-lam/lifts)]
[else (show "schemified" impl-lam/lifts)])
[(jit) (show pre-jit-on? "pre-jitified" impl-lam)]
[else (show "schemified" impl-lam)])
;; don't need extract for non-serializable 'lambda mode
(or serializable? (eq? linklet-compilation-mode 'jit))
;; need lift only for serializable JIT mode

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

@ -734,8 +734,7 @@
current-atomic-virtual-register
end-atomic-virtual-register
current-future-virtual-register)
(import (rename (chezpart)
[define define/no-lift])
(import (chezpart)
(rename (only (chezscheme) sleep)
[sleep chez:sleep])
(only (chezscheme)
@ -752,10 +751,9 @@
record-field-mutator))
;; Internal tokens that are different from all possible user-level values:
(define/no-lift none '#{none kwcju864gpycc2h151s9atbmo-1})
(define/no-lift none2 '#{none kwcju864gpycc2h151s9atbmo-2}) ; never put this in an emphemeron
(define none '#{none kwcju864gpycc2h151s9atbmo-1})
(define none2 '#{none kwcju864gpycc2h151s9atbmo-2}) ; never put this in an emphemeron
(include "rumble/define.ss")
(include "rumble/virtual-register.ss")
(include "rumble/layout.ss")
(include "rumble/begin0.ss")

30
racket/src/cs/rumble/check.ss
View File

@ -2,24 +2,18 @@
(define-syntax (who stx)
(syntax-error stx "not bound"))
(define-syntax-rule (define-define/who define/who define)
(...
(define-syntax (define/who stx)
(syntax-case stx ()
[(_ (id . args) body ...)
#'(define id
(fluid-let-syntax ([who (lambda (stx)
#''id)])
(lambda args body ...)))]
[(_ id rhs)
#'(define id
(fluid-let-syntax ([who (lambda (stx)
#''id)])
rhs))]))))
(define-define/who define/who define)
(define-define/who define/lift/who define/lift)
(define-define/who define/no-lift/who define/no-lift)
(define-syntax (define/who stx)
(syntax-case stx ()
[(_ (id . args) body ...)
#'(define id
(fluid-let-syntax ([who (lambda (stx)
#''id)])
(lambda args body ...)))]
[(_ id rhs)
#'(define id
(fluid-let-syntax ([who (lambda (stx)
#''id)])
rhs))]))
(define-syntax (check stx)
(syntax-case stx (:test :contract :or-false)

571
racket/src/cs/rumble/define.ss
View File

@ -1,571 +0,0 @@
;; Replace `define` to perform simple function lifting, which avoids
;; having to allocate closures for local loops (i.e., a more
;; Racket-like allocation model). Since it only has to work for
;; Rumble's implementation, the lifter doesn't have to be general or
;; scalable. The lifter transforms unexpanded source expressions, so
;; it needs to recognize all of the forms that are used inside
;; `define` forms.
;; Only functions bound with named `let`, normal `let` with `lambda`,
;; and `let*` with `lamdba` are lifted, and the lifter assumes that a
;; named `let`'s identifier is used only in application position.
;; Local `define` is not allowed.
;; To bind a `let`-bound function that is not used only in an
;; application position, wrap it with `escapes-ok`.
;; If a function F includes a call to a function G, function G has a
;; free variable X, and function F has an argument X, then the lifter
;; doesn't work (and it reports an error). Help the lifter in that
;; case by picking a different name for one of the Xs.
;; If a "loop" is a non-tail loop or if has many free variables, then
;; lifting may be counterproductive (by making a bad trade for less
;; allocation but slower GCs). Use `define/no-lift` in that case.
;; Select `define/lift` as the default mode:
(define-syntax (define stx)
(syntax-case stx ()
[(_ . r) #'(define/lift . r)]))
(define-syntax (define/lift stx)
(letrec ([lift-local-functions
;; Convert `e` to return
;; (list new-list (list lifted-defn ...))
;; The `env` argument is a list of symbols (not identifiers),
;; and the `binds` argument is a list of syntax bindings
;; #`(bind-form ([id rhs] ...))
;; to be copied over to any lifted form. Also, the `rhs`
;; of a `bind-form` can contain free-variable and
;; called-variable information for a previously lifted
;; function, so that its free variables can be added
;; as needed to a newly lifted function that calls the
;; lifted one.
;; Earlier entries in `binds` shadow later ones, and
;; entires in `env` shadow `binds` entries.
(lambda (e env binds mutated)
(syntax-case e (quote begin lambda case-lambda
let letrec let* let-values
fluid-let-syntax let-syntax
cond define set!)
[(define . _)
(syntax-error e "don't use nested `define`:")]
[(quote _)
(list e '())]
[(begin e)
(lift-local-functions #'e env binds mutated)]
[(seq e ...)
(and (symbol? (syntax->datum #'seq))
(or (free-identifier=? #'seq #'begin)
(free-identifier=? #'seq #'begin0)
(free-identifier=? #'seq #'if)))
(with-syntax ([((new-e lifts) ...)
(map (lambda (e)
(lift-local-functions e env binds mutated))
#'(e ...))])
(list #'(seq new-e ...)
(append-all #'(lifts ...))))]
[(lambda args e ...)
(with-syntax ([(body lifts)
(lift-local-functions #'(begin e ...)
(add-args env #'args)
binds
mutated)])
#`((lambda args body)
lifts))]
[(case-lambda [args e ...] ...)
(with-syntax ([((body lifts) ...)
(map (lambda (args body)
(lift-local-functions body
(add-args env args)
binds
mutated))
#'(args ...)
#'((begin e ...) ...))])
(list #'(case-lambda [args body] ...)
(append-all #'(lifts ...))))]
[(let loop ([arg val] ...) body-e ...)
(symbol? (syntax->datum #'loop))
(cond
[(true-loop? (syntax->datum #'loop) #t #'(begin body-e ...))
(lift-local-functions-in-named-let e env binds mutated)]
[else
(generate-lifted env binds mutated
#'loop ; name
#'(arg ...) ; argument names
#'(begin body-e ...) ; body
#t ; recursive
(lambda (defn-to-lift new-loop-name free-vars wrap-bind-of-lifted)
(with-syntax ([(free-var ...) free-vars]
[new-loop-name new-loop-name]
[defn-to-lift defn-to-lift])
#`((new-loop-name val ... free-var ...)
(defn-to-lift)))))])]
[(let* () e ...)
(lift-local-functions #`(begin e ...) env binds mutated)]
[(let* ([id rhs] . more-binds) e ...)
(lift-local-functions #`(let ([id rhs]) (let* more-binds e ...)) env binds mutated)]
[(let . _)
(lift-local-functions-in-let/lift-immediate e env binds mutated)]
[(letrec . _)
(lift-local-functions-in-let e env binds mutated #t)]
[(let-values ([(id ...) rhs] ...) e ...)
(with-syntax ([((new-rhs lifts) ...)
(map (lambda (rhs)
(lift-local-functions rhs env binds mutated))
#'(rhs ...))])
(with-syntax ([(new-body body-lifts)
(lift-local-functions #'(begin e ...)
(add-args env (#%apply append #'((id ...) ...)))
binds
mutated)])
(list #'(let-values ([(id ...) new-rhs] ...) new-body)
(append #'body-lifts (append-all #'(lifts ...))))))]
[(fluid-let-syntax ([id rhs] ...) e ...)
(with-syntax ([(new-body body-lifts)
(lift-local-functions #'(begin e ...)
(remove-args env #'(id ...))
(cons #'(fluid-let-syntax ([id rhs] ...))
binds)
mutated)])
#`((fluid-let-syntax ([id rhs] ...) new-body)
body-lifts))]
[(let-syntax ([id rhs] ...) e ...)
(with-syntax ([(new-body body-lifts)
(lift-local-functions #'(begin e ...)
(remove-args env #'(id ...))
(cons #'(let-syntax ([id rhs] ...))
binds)
mutated)])
#`((let-syntax ([id rhs] ...) new-body)
body-lifts))]
[(cond [e ...] ...)
(with-syntax ([(((new-e lifts) ...) ...)
(map (lambda (es)
(map (lambda (e)
(lift-local-functions e env binds mutated))
es))
#'((e ...) ...))])
(list #'(cond [new-e ...] ...)
(append-all (append-all #'((lifts ...) ...)))))]
[(set! id rhs)
(track-mutated! mutated #'id 'mutated)
(with-syntax ([(new-rhs lifts) (lift-local-functions #'rhs env binds mutated)])
#'((set! id new-rhs)
lifts))]
[(rator rand ...)
(with-syntax ([((new-e lifts) ...)
(map (lambda (e)
(lift-local-functions e env binds mutated))
#'(rator rand ...))])
(list #'(new-e ...)
(append-all #'(lifts ...))))]
[_ (list e '())]))]
[lift-local-functions-in-let
(lambda (e env binds mutated rec?)
(syntax-case e ()
[(form ([id rhs] ...) e ...)
(let ([body-env (add-args env #'(id ...))])
(with-syntax ([((new-rhs lifts) ...)
(map (lambda (rhs)
(lift-local-functions rhs (if rec? body-env env) binds mutated))
#'(rhs ...))])
(with-syntax ([(new-body body-lifts)
(lift-local-functions #'(begin e ...) body-env binds mutated)])
(list #'(form ([id new-rhs] ...) new-body)
(append #'body-lifts (append-all #'(lifts ...)))))))]))]
[lift-local-functions-in-let/lift-immediate
;; Split `lambda` bindings for other bindings, then lift the `lambda`s
(lambda (e env binds mutated)
(syntax-case e ()
[(form ([id rhs] ...) . body)
(let ([body-env (add-args env #'(id ...))])
(let-values ([(proc-binds other-binds)
(split-proc-binds #'([id rhs] ...))])
(cond
[(null? proc-binds)
(lift-local-functions-in-let e env binds mutated #f)]
[else
(let loop ([proc-binds proc-binds]
[e (with-syntax ([other-binds other-binds])
#'(form other-binds . body))]
[lifts '()])
(cond
[(null? proc-binds)
(with-syntax ([(new-e e-lifts) (lift-local-functions e env binds mutated)])
(list #'new-e
(append lifts #'e-lifts)))]
[else
(with-syntax ([[id (_ rhs-args rhs-e ...)] (car proc-binds)])
(generate-lifted
env binds mutated
#'id ; name
#'rhs-args ; argument names
#'(begin rhs-e ...) ; body
#f ; not recursive
(lambda (defn-to-lift new-id free-vars wrap-bind-of-lifted)
(loop (cdr proc-binds)
(wrap-bind-of-lifted e)
(cons defn-to-lift lifts)))))]))])))]))]
[lift-local-functions-in-named-let
(lambda (e env binds mutated)
(syntax-case e ()
[(form loop ([id rhs] ...) e ...)
(let ([body-env (add-args env #'(id ...))])
(with-syntax ([((new-rhs lifts) ...)
(map (lambda (rhs)
(lift-local-functions rhs env binds mutated))
#'(rhs ...))])
(with-syntax ([(new-body body-lifts)
(lift-local-functions #'(begin e ...) body-env binds mutated)])
(list #'(form loop ([id new-rhs] ...) new-body)
(append #'body-lifts (append-all #'(lifts ...)))))))]))]
[split-proc-binds
;; Helper to split `lambda` from non-`lambda`
(lambda (form-binds)
(let loop ([binds form-binds] [proc-binds '()] [other-binds '()])
(cond
[(null? binds)
(values (reverse proc-binds)
(reverse other-binds))]
[else
(syntax-case (car binds) (lambda)
[[_ (lambda (arg ...) . _)]
(loop (cdr binds)
(cons (car binds) proc-binds)
other-binds)]
[_
(loop (cdr binds)
proc-binds
(cons (car binds) other-binds))])])))]
[generate-lifted
;; Takes pieces for a function to lift an generates the lifted version
(lambda (env binds mutated name args body rec? k)
(let* ([ids (if rec? (cons name args) args)]
[binds (filter-shadowed-binds binds (add-args env ids))]
[body-env (remove-args env ids)]
[direct-free-vars (extract-free-vars body body-env)]
[direct-called-vars (extract-free-vars body (binds-to-env binds))])
(for-each (lambda (free-var) (track-mutated! mutated free-var 'must-not)) direct-free-vars)
(let-values ([(free-vars called-vars) (extract-bind-vars binds body-env direct-free-vars direct-called-vars)])
(let ([free-vars (unique-ids free-vars)]
[called-vars (unique-ids called-vars)])
(with-syntax ([(free-var ...) free-vars]
[(called-var ...) called-vars]
[new-name (datum->syntax
name
(#%gensym (#%symbol->string (syntax->datum name))))]
[body (let loop ([body body]
[binds binds])
(cond
[(null? binds) body]
[else (with-syntax ([(form form-binds) (car binds)]
[body body])
(loop #'(form form-binds body)
(cdr binds)))]))]
[name name]
[(arg ...) args])
(let ([wrap-bind-of-lifted
(lambda (body)
(with-syntax ([body body])
#'(let-syntax ([name (begin ; this pattern is recognized by `extract-bind-free-vars`
'(FREE-VARS free-var ...)
'(CALLED-VARS called-var ...)
(lambda (stx)
(syntax-case stx ()
[(_ call-arg (... ...))
#'(new-name call-arg (... ...) free-var ...)]
[_ (syntax-error stx "lifted procedure escapes:")])))])
body)))])
(with-syntax ([wrapped-body (if rec?
(wrap-bind-of-lifted #'body)
#'body)])
(k #`(define/lift new-name
(lambda (arg ... free-var ...)
wrapped-body))
#'new-name
free-vars
wrap-bind-of-lifted))))))))]
[extract-free-vars
;; For an expression that is going to be lifted, find all the free
;; variables so they can be added to call sites of the enclosing
;; lifted function. Only variables in `env` are candidate free
;; variables.
(lambda (e env)
(syntax-case e (quote begin lambda case-lambda
let* let letrec let-values
fluid-let-syntax let-syntax
set!)
[id
(symbol? (syntax->datum #'id))
(if (chez:memq (syntax->datum #'id) env)
(list #'id)
'())]
[(set! id rhs)
(if (chez:memq (syntax->datum #'id) env)
(syntax-error #'id "cannot mutate variable added to lifted procedure:")
(extract-free-vars #'rhs env))]
[(quote _) '()]
[(seq e ...)
(and (symbol? (syntax->datum #'seq))
(or (free-identifier=? #'seq #'begin)
(free-identifier=? #'seq #'begin0)
(free-identifier=? #'seq #'if)
(free-identifier=? #'seq #'cond)))
(#%apply append (map (lambda (e)
(extract-free-vars e env))
#'(e ...)))]
[(lambda args e ...)
(extract-free-vars #'(begin e ...)
(remove-args env #'args))]
[(case-lambda [args e ...] ...)
(#%apply
append
(map (lambda (args body)
(extract-free-vars body (remove-args env args)))
#'(args ...)
#'((begin e ...) ...)))]
[(let loop ([arg val] ...) e ...)
(symbol? (syntax->datum #'loop))
(append
(extract-free-vars #'(begin val ...) env)
(extract-free-vars #'(begin e ...)
(remove-args env #'(loop arg ...))))]
[(let* () e ...)
(extract-free-vars #`(begin e ...) env)]
[(let* ([id rhs] . binds) e ...)
(extract-free-vars #`(let ([id rhs]) (let* binds e ...)) env)]
[(let ([id rhs] ...) e ...)
(append
(extract-free-vars #'(begin rhs ...) env)
(extract-free-vars #'(begin e ...) (remove-args env #'(id ...))))]
[(let-values ([(id ...) rhs] ...) e ...)
(append
(extract-free-vars #'(begin rhs ...) env)
(extract-free-vars #'(begin e ...) (remove-args env (#%apply append #'((id ...) ...)))))]
[(letrec ([id rhs] ...) e ...)
(extract-free-vars #'(begin rhs ... e ...) (remove-args env #'(id ...)))]
[(fluid-let-syntax ([id rhs] ...) e ...)
(extract-free-vars #'(begin e ...) (remove-args env #'(id ...)))]
[(let-syntax ([id rhs] ...) e ...)
(extract-free-vars #'(begin e ...) (remove-args env #'(id ...)))]
[(rator rand ...)
(extract-free-vars #'(begin rator rand ...) env)]
[_ '()]))]
[true-loop?
(lambda (name tail? e)
(syntax-case e (quote begin begin0 if cond lambda case-lambda
let* let letrec let-values
fluid-let-syntax let-syntax
set!)
[id
(symbol? (syntax->datum #'id))
(not (eq? (syntax->datum #'id) name))]
[(set! id rhs)
(and (not (eq? (syntax->datum #'id) name))
(true-loop? name #f e))]
[(quote _) '()]
[(begin e ... e0)
(and (#%andmap (lambda (e) (true-loop? name #f e))
#'(e ...))
(true-loop? name tail? #'e0))]
[(begin0 e ...)
(#%andmap (lambda (e) (true-loop? name #f e))
#'(e ...))]
[(if e0 e1 e2)
(and (true-loop? name #f #'e0)
(true-loop? name tail? #'e1)
(true-loop? name tail? #'e2))]
[(cond [test expr ...] ...)
(#%andmap (lambda (b) (true-loop? name #f b))
#'((begin test expr ...) ...))]
[(lambda args e ...) #f]
[(case-lambda [args e ...] ...) #f]
[(let loop ([arg val] ...) e ...)
(or (eq? name (syntax->datum #'loop))
(and
(#%andmap (lambda (val) (true-loop? name #f val))
#'(val ...))
(true-loop? name tail? #'(begin e ...))))]
[(let* () e ...)
(true-loop? name tail? #'(begin e ...))]
[(let* ([id rhs] . binds) e ...)
(true-loop? name tail? #`(let ([id rhs]) (let* binds e ...)))]
[(let ([id rhs] ...) e ...)
(and (#%andmap (lambda (rhs) (true-loop? name #f #'rhs))
#'(rhs ...))
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
#'(id ...))
(true-loop? name tail? #'(begin e ...))))]
[(let-values ([(id ...) rhs] ...) e ...)
(and (#%andmap (lambda (rhs) (true-loop? name #f #'rhs))
#'(rhs ...))
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
#'(id ... ...))
(true-loop? name tail? #'(begin e ...))))]
[(letrec ([id rhs] ...) e ...)
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
#'(id ...))
(and (#%andmap (lambda (rhs) (true-loop? name #f #'rhs))
#'(rhs ...))
(true-loop? name tail? #'(begin e ...))))]
[(fluid-let-syntax ([id rhs] ...) e ...)
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
#'(id ...))
(true-loop? name tail? #'(begin e ...)))]
[(let-syntax ([id rhs] ...) e ...)
(or (#%ormap (lambda (id) (eq? (syntax->datum id) name))
#'(id ...))
(true-loop? name tail? #'(begin e ...)))]
[(rator rand ...)
(and (or (and tail?
(eq? name (syntax->datum #'rator)))
(true-loop? name #f #'rator))
(#%andmap (lambda (rand) (true-loop? name #f rand))
#'(rand ...)))]
[_ #t]))]
[filter-shadowed-binds
;; Simplify `binds` to drop bindings that are shadowned by
;; `env` or by earlier bindings
(lambda (binds env)
(let loop ([binds binds]
[env env])
(cond
[(null? binds) '()]
[else (with-syntax ([(form ([id rhs] ...)) (car binds)])
(with-syntax ([([id rhs] ...)
;; Filter any `ids` that are shadowed
(let loop ([ids #'(id ...)] [rhss #'(rhs ...)])
(cond
[(null? ids) '()]
[(chez:memq (syntax->datum (car ids)) env)
(loop (cdr ids) (cdr rhss))]
[else (cons (list (car ids) (car rhss))
(loop (cdr ids) (cdr rhss)))]))])
(cons #'(form ([id rhs] ...))
(loop (cdr binds)
(add-args env #'(id ...))))))])))]
[binds-to-env
;; Extract the identifiers of `binds` into an environment
(lambda (binds)
(let loop ([binds binds] [env '()])
(cond
[(null? binds) env]
[else
(loop (cdr binds)
(syntax-case (car binds) ()
[(form ([id rhs] ...))
(add-args env #'(id ...))]))])))]
[extract-bind-vars
;; Add new variables to `free-vars` and `called-vars` based on
;; entries in `all-binds` that will be called (because they're
;; referenced in `called-vars`). A fixpoint calculation is needed,
;; since calling a lifted function may add new free variables and
;; new called variables.
(lambda (all-binds env free-vars called-vars)
(let loop ([binds all-binds] [added? #f] [free-vars free-vars] [called-vars called-vars] [did-ids '()])
(cond
[(null? binds) (if added?
;; Loop to fixpoint
(loop all-binds #f free-vars called-vars did-ids)
;; Found fixpoint
(values free-vars called-vars))]
[else (syntax-case (car binds) (FREE-VARS CALLED-VARS begin quote)
[(form ([id (begin
'(FREE-VARS free-var ...)
'(CALLED-VARS called-var ...)
_)]))
(and (id-member? #'id called-vars)
(not (chez:memq (syntax->datum #'id) did-ids)))
(loop (cdr binds)
#t
(append (#%map (lambda (free-var)
(if (chez:memq (syntax->datum free-var) env)
free-var
(syntax-error free-var "wrong variable at call site; lifter needs your help by renaming:")))
#'(free-var ...))
free-vars)
(append #'(called-var ...)
called-vars)
(cons (syntax->datum #'id) did-ids))]
[_
;; Not a lifted-function binding
(loop (cdr binds) added? free-vars called-vars did-ids)])])))]
[add-args
;; Add identifiers (accomdating rest args) to an environment
(lambda (env args)
(let add-args ([env env] [args (syntax->datum args)])
(cond
[(null? args) env]
[(pair? args) (add-args (cons (car args) env)
(cdr args))]
[else (cons args env)])))]
[remove-args
;; Remove identifiers (accomdating rest args) from an environment
(lambda (env args)
(let remove-args ([env env] [args (syntax->datum args)])
(cond
[(null? args) env]
[(pair? args) (remove-args (#%remq (car args) env)
(cdr args))]
[else (#%remq args env)])))]
[track-mutated!
(lambda (mutated id state)
(let ([old-state (hashtable-ref mutated (syntax->datum id) #f)])
(when (and old-state
(not (eq? old-state state)))
(syntax-error id "lift seems to need to close over mutated variable:"))
(hashtable-set! mutated (syntax->datum id) state)))]
[unique-ids
(lambda (l)
(let loop ([l l])
(cond
[(null? l) '()]
[(id-member? (car l) (cdr l))
(loop (cdr l))]
[else (cons (car l) (loop (cdr l)))])))]
[id-member?
(lambda (id l)
(let loop ([l l])
(cond
[(null? l) #f]
[else (or (free-identifier=? id (car l))
(loop (cdr l)))])))]
[append-all
(lambda (l)
(#%apply append l))])
;; Traverse the right-hand side of a definition to extract lifts
(syntax-case stx ()
[(_ (id . args) e ...)
#'(define/lift id (lambda args e ...))]
[(_ id rhs)
(with-syntax ([(new-rhs (lift ...)) (lift-local-functions
#'rhs
'()
'()
(make-eq-hashtable))])
#'(define/no-lift id
(let ()
lift ...
new-rhs)))])))
(define-syntax (escapes-ok stx)
(syntax-case stx ()
[(_ e) #'e]))

11
racket/src/cs/rumble/error.ss
View File

@ -464,12 +464,11 @@
(fields value))
(define make-unquoted-printing-string
(let ([unquoted-printing-string
(escapes-ok
(lambda (s)
(check 'unquoted-printing-string string? s)
(new-unquoted-printing-string s)))])
unquoted-printing-string))
(|#%name|
unquoted-printing-string
(lambda (s)
(check 'unquoted-printing-string string? s)
(new-unquoted-printing-string s))))
;; ----------------------------------------

41
racket/src/cs/rumble/foreign.ss
View File

@ -525,14 +525,13 @@
[(types abi alignment) (make-cstruct-type types abi alignment 'atomic)]
[(types abi alignment malloc-mode)
(let ([make-decls
(escapes-ok
(lambda (id next!-id)
(let-values ([(reps decls) (types->reps types next!-id)])
(append decls
`((define-ftype ,id
(struct ,@(map (lambda (rep)
`[,(next!-id) ,rep])
reps))))))))])
(lambda (id next!-id)
(let-values ([(reps decls) (types->reps types next!-id)])
(append decls
`((define-ftype ,id
(struct ,@(map (lambda (rep)
`[,(next!-id) ,rep])
reps)))))))])
(let-values ([(size alignment) (ctypes-sizeof+alignof types alignment)])
(create-compound-ctype 'struct
'struct
@ -548,14 +547,13 @@
(for-each (lambda (type) (check who ctype? type))
types)
(let ([make-decls
(escapes-ok
(lambda (id next!-id)
(let-values ([(reps decls) (types->reps types next!-id)])
(append decls
`((define-ftype ,id
(union ,@(map (lambda (rep)
`[,(next!-id) ,rep])
reps))))))))]
(lambda (id next!-id)
(let-values ([(reps decls) (types->reps types next!-id)])
(append decls
`((define-ftype ,id
(union ,@(map (lambda (rep)
`[,(next!-id) ,rep])
reps)))))))]
[size (apply max (map ctype-sizeof types))]
[alignment (apply max (map ctype-alignof types))])
(create-compound-ctype 'union
@ -572,12 +570,11 @@
(check who ctype? type)
(check who exact-nonnegative-integer? count)
(let ([make-decls
(escapes-ok
(lambda (id next!-id)
(let-values ([(reps decls) (types->reps (list type) next!-id)])
(append decls
`((define-ftype ,id
(array ,count ,(car reps))))))))]
(lambda (id next!-id)
(let-values ([(reps decls) (types->reps (list type) next!-id)])
(append decls
`((define-ftype ,id
(array ,count ,(car reps)))))))]
[size (* count (ctype-sizeof type))]
[alignment (ctype-alignof type)])
(unless (fixnum? size)

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

@ -677,11 +677,10 @@
(define (set-impersonator-hash!)
(let ([struct-impersonator-hash-code
(escapes-ok
(lambda (c hash-code)
((record-hash-procedure (impersonator-val c))
c
hash-code)))])
(lambda (c hash-code)
((record-hash-procedure (impersonator-val c))
c
hash-code))])
(let ([add (lambda (rtd)
(record-type-hash-procedure rtd struct-impersonator-hash-code))])
(add (record-type-descriptor struct-impersonator))

2
racket/src/cs/rumble/list.ss
View File

@ -34,7 +34,7 @@
;; compatilation approach
(define-syntax-rule (define-list-proc |#%name| name base combine)
(define/no-lift |#%name|
(define |#%name|
(case-lambda
[(f l)
(if (list? l)

34
racket/src/cs/rumble/struct.ss
View File

@ -218,19 +218,18 @@
(let ([props-ht
;; Check for duplicates and record property values
(let ([get-struct-info
(escapes-ok
(lambda ()
(let ([parent-total*-count (if parent-rtd*
(struct-type-total*-field-count parent-rtd*)
0)])
(list name
init-count
auto-count
(make-position-based-accessor rtd parent-total*-count (+ init-count auto-count))
(make-position-based-mutator rtd parent-total*-count (+ init-count auto-count))
all-immutables
parent-rtd
#f))))])
(lambda ()
(let ([parent-total*-count (if parent-rtd*
(struct-type-total*-field-count parent-rtd*)
0)])
(list name
init-count
auto-count
(make-position-based-accessor rtd parent-total*-count (+ init-count auto-count))
(make-position-based-mutator rtd parent-total*-count (+ init-count auto-count))
all-immutables
parent-rtd
#f)))])
(let loop ([props props] [ht empty-hasheq])
(cond
[(null? props)
@ -951,11 +950,10 @@
(let ([rtd* (strip-impersonator rtd)])
(check-inspector-access who rtd*)
(|#%struct-predicate|
(escapes-ok
(lambda (v)
(or (record? v rtd*)
(and (impersonator? v)
(record? (impersonator-val v) rtd*))))))))
(lambda (v)
(or (record? v rtd*)
(and (impersonator? v)
(record? (impersonator-val v) rtd*)))))))
;; ----------------------------------------

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

@ -1,6 +1,5 @@
(library (schemify)
(export schemify-linklet
lift-in-schemified-linklet
jitify-schemified-linklet
xify
interpreter-link!

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

@ -520,7 +520,7 @@
(find-loops rand lifts #hasheq() loops))])
(cond
[(not (hash-ref loops u-id #f))
(find-loops rhs #hasheq() loops)]
(find-loops rhs lifts #hasheq() loops)]
[else
(define new-loop-if-tail
(hash-set (for/hasheq ([(id bx) (in-hash loop-if-tail)])

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

@ -1,7 +1,6 @@
#lang racket/base
(require "schemify.rkt"
"known.rkt"
"lift.rkt"
"jitify.rkt"
"xify.rkt"
"fasl-literal.rkt"
@ -14,9 +13,6 @@
(all-from-out "known.rkt")
lift-in-schemified-linklet
lift-in-schemified-body
jitify-schemified-linklet
xify

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

@ -898,28 +898,22 @@
(cdr e)
#f target
prim-knowns knowns imports mutated simples))]
[(and (not (or
;; Don't inline in cify mode, because cify takes care of it
(aim? target 'cify)
;; Don't inline in 'system mode, because there will
;; be no `|#%struct-constructor| in the way, and
;; it's more readable to use the normal constructor name
(aim? target 'system)))
;; Struct procedures are only inlined for imported values, which implies
;; a non-cify, non-system target; for non-imported values, we expect a
;; later pass to be able to handle things
[(and im
(known-struct-constructor? k)
(inline-struct-constructor k s-rator im args))
=> (lambda (e) e)]
[(and (not (or (aim? target 'cify)
(aim? target 'system)))
[(and im
(known-struct-predicate? k)
(inline-struct-predicate k s-rator im args))
=> (lambda (e) e)]
[(and (not (or (aim? target 'cify)
(aim? target 'system)))
[(and im
(known-field-accessor? k)
(inline-field-access k s-rator im args))
=> (lambda (e) e)]
[(and (not (or (aim? target 'cify)
(aim? target 'system)))
[(and im
(known-field-mutator? k)
(inline-field-mutate k s-rator im args))
=> (lambda (e) e)]

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 14
#define MZSCHEME_VERSION_W 15
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x