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

cs: faster Chez Scheme bootstrap

Browse Source 
Improve record encoding to make it more exposed to the compiler.
This commit is contained in:
Matthew Flatt 2019-04-20 13:27:02 -06:00
parent 8c8979369f
commit 4b586eeadf
2 changed files with 77 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
racket/src/cs/bootstrap/record.rkt
View File

@ -21,6 +21,9 @@
record-predicate
record-accessor
record-mutator
compile-time-record-predicate
compile-time-record-accessor
compile-time-record-mutator
csv7:record-field-accessor
csv7:record-field-mutator
csv7:record-field-mutable?
@ -190,6 +193,18 @@
(pred (hash-ref rtd-extensions v #f))
(pred v)))]))
(define (compile-time-record-predicate rtd)
(and (not (base-rtd-subtype-rtd? rtd))
(struct-type-make-predicate rtd)))
(define (base-rtd-subtype-rtd? rtd)
(or (eq? struct:base-rtd-subtype rtd)
(let ()
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info rtd))
(or (not super)
(base-rtd-subtype-rtd? super)))))
;; `i` does not count parent fields
(define (record-accessor rtd i [name #f])
(cond
@ -206,7 +221,12 @@
rtd/ext)))
acc)]))
(define mutators (make-weak-hasheq))
(define (compile-time-record-accessor rtd i)
(and (not (base-rtd-subtype-rtd? rtd))
(let ()
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info rtd))
(make-struct-field-accessor ref i))))
;; `i` does not count parent fields
(define (record-mutator rtd i [name #f])
@ -214,6 +234,13 @@
(struct-type-info rtd))
(make-struct-field-mutator set i name))
(define (compile-time-record-mutator rtd i)
(and (not (base-rtd-subtype-rtd? rtd))
(let ()
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info rtd))
(make-struct-field-mutator set i))))
(define base-rtd-fields
(map vector-copy
'(#(fld parent #f scheme-object 9)

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

@ -17,6 +17,7 @@
"scheme-struct.rkt"
"symbol.rkt"
"record.rkt"
(for-syntax "record.rkt")
"constant.rkt"
(only-in "r6rs-lang.rkt"
make-record-constructor-descriptor
@ -30,13 +31,13 @@
[gen-let-values let-values]
[s:module module]
[s:parameterize parameterize]
[letrec letrec*]
[s:dynamic-wind dynamic-wind])
set-who!
import
include
when-feature
fluid-let
letrec*
putprop getprop remprop
$sputprop $sgetprop $sremprop
prim-mask
@ -355,6 +356,53 @@
(lambda () body ...)
swap)))]))
;; Help the Racket compiler by lifting immediate record operations out
;; of a `letrec`. Otherwise, the Racket compiler cannot figure out that
;; they won't capture continuations, etc., and will make access slow.
;; We may even be able to substitute a literal procedure, since all record
;; types are prefab structs.
(define-syntax (letrec* stx)
(syntax-case stx ()
[(_ (clause ...) . body)
(let loop ([clauses (syntax->list #'(clause ...))] [lets '()] [letrecs '()])
(cond
[(null? clauses)
#`(let #,(reverse lets)
(letrec #,(reverse letrecs)
. body))]
[else
(syntax-case* (car clauses) ($primitive quote record-accessor record-predicate) (lambda (a b)
(eq? (syntax-e a)
(syntax-e b)))
[[id (($primitive _ record-accessor) 'rtd n)]
(and (struct-type? (syntax-e #'rtd))
(integer? (syntax-e #'n)))
(let ([a (compile-time-record-accessor (syntax-e #'rtd) (syntax-e #'n))])
(loop (cdr clauses) (cons (if a
#`[id '#,a]
(car clauses))
lets)
letrecs))]
[[id (($primitive _ record-mutator) 'rtd n)]
(and (struct-type? (syntax-e #'rtd))
(integer? (syntax-e #'n)))
(let ([m (compile-time-record-mutator (syntax-e #'rtd) (syntax-e #'n))])
(loop (cdr clauses) (cons (if m
#`[id '#,m]
(car clauses))
lets)
letrecs))]
[[id (($primitive _ record-predicate) 'rtd)]
(struct-type? (syntax-e #'rtd))
(let ([p (compile-time-record-predicate (syntax-e #'rtd))])
(loop (cdr clauses) (cons (if p
#`[id '#,p]
(car clauses))
lets)
letrecs))]
[else
(loop (cdr clauses) lets (cons (car clauses) letrecs))])]))]))
(define-syntax (s:parameterize stx)
(syntax-case stx ()
[(_ ([id rhs] ...) body ...)