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

CS bootstrap: avoid pessimizing primitives

Browse Source 
Speed up the bootstrap process by more directly referencing primitives
that won't be replaced in the top-lvel namespace for simulating Chez
Scheme.
This commit is contained in:
Matthew Flatt 2019-07-05 14:44:02 -06:00
parent 1e7dbbe020
commit c0104a29ef
3 changed files with 52 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
racket/src/cs/bootstrap/make-boot.rkt
View File

@ -66,7 +66,34 @@
(namespace-attach-module (current-namespace) r6rs-lang-mod ns)
(namespace-attach-module (current-namespace) scheme-lang-mod ns)
(namespace-require/copy r6rs-lang-mod ns) ; get `library`
(namespace-require r6rs-lang-mod ns) ; get `library`
;; Change some bindings from imported to top-level references so that
;; expressions are compiled to reference variables that are updated by
;; loading the Chez Scheme compiler. This approach is better than
;; using `namespace-require/copy`, because we want most primitives to
;; be referenced directly to make the compiler run faster.
(define (reset-toplevels [more '()])
(for-each (lambda (sym)
(eval `(define ,sym ,sym) ns))
(append
more
'(identifier?
datum->syntax
syntax->list
syntax->datum
generate-temporaries
free-identifier=?
bound-identifier=?
make-compile-time-value
current-eval
eval
expand
compile
error
format))))
(reset-toplevels)
(status "Load nanopass")
(define (load-nanopass)
@ -88,9 +115,14 @@
(load/cd (build-path nano-dir "nanopass/implementation-helpers.ikarus.ss"))
(load-nanopass))
(namespace-require/copy ''nanopass ns)
(namespace-require ''nanopass ns)
(namespace-require/copy scheme-lang-mod ns)
(namespace-require scheme-lang-mod ns)
(reset-toplevels '(run-cp0
errorf
$oops
$undefined-violation
generate-interrupt-trap))
(namespace-require `(for-syntax ,r6rs-lang-mod) ns)
(namespace-require `(for-syntax ,scheme-lang-mod) ns)

19
racket/src/cs/bootstrap/r6rs-lang.rkt
View File

@ -18,7 +18,10 @@
do-$make-record-type
register-rtd-name!
register-rtd-fields!
s:struct-type?)
s:struct-type?
record-predicate
record-accessor
record-mutator)
(only-in "immediate.rkt"
base-rtd)
(only-in "scheme-struct.rkt"
@ -45,7 +48,8 @@
if
sort
fixnum?
open-output-file)
open-output-file
dynamic-wind)
library import export
(rename-out [patch:define define]
[s:syntax syntax]
@ -61,7 +65,8 @@
[s:splicing-let-syntax let-syntax]
[s:splicing-letrec-syntax letrec-syntax]
[let trace-let]
[define trace-define])
[define trace-define]
[s:dynamic-wind dynamic-wind])
guard
identifier-syntax
(for-syntax datum)
@ -79,6 +84,9 @@
record-constructor-descriptor
record-constructor
(rename-out [record-constructor r6rs:record-constructor])
record-predicate
record-accessor
record-mutator
record-constructor-descriptor?
syntax-violation
port-position
@ -372,6 +380,11 @@
[(_ else) #t]
[(_ e) e]))
(define s:dynamic-wind
(case-lambda
[(pre thunk post) (dynamic-wind pre thunk post)]
[(critical? pre thunk post) (dynamic-wind pre thunk post)]))
(begin-for-syntax
(define-syntax-rule (with-implicit (tid id ...) body ...)
(with-syntax ([id (datum->syntax (syntax tid) 'id)] ...)

11
racket/src/cs/bootstrap/scheme-lang.rkt
View File

@ -32,8 +32,7 @@
[s:define define-who]
[gen-let-values let-values]
[s:module module]
[s:parameterize parameterize]
[s:dynamic-wind dynamic-wind])
[s:parameterize parameterize])
set-who!
import
include
@ -67,9 +66,6 @@
with-values
make-record-type
type-descriptor
record-predicate
record-accessor
record-mutator
csv7:record-field-accessor
csv7:record-field-mutator
csv7:record-field-mutable?
@ -586,11 +582,6 @@
(lambda lhs (values . flat-lhs)))])]))])
#'(let-values ([lhs rhs] ...) body ...))]))
(define s:dynamic-wind
(case-lambda
[(pre thunk post) (dynamic-wind pre thunk post)]
[(critical? pre thunk post) (dynamic-wind pre thunk post)]))
(define-values (prim-flags->bits primvec get-priminfo)
(get-primdata $sputprop scheme-dir))