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

speed up Chez Scheme bootstrap a little

Browse Source 
Recognize constructor patterns to avoid some indirections.
This commit is contained in:
Matthew Flatt 2019-07-05 06:22:15 -06:00
parent f0314ddad7
commit 3235f648fb
4 changed files with 242 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,6 +2,7 @@
(require racket/runtime-path (require racket/runtime-path
racket/match racket/match
racket/file racket/file
racket/pretty
(only-in "r6rs-lang.rkt" (only-in "r6rs-lang.rkt"
optimize-level) optimize-level)
(only-in "scheme-lang.rkt" (only-in "scheme-lang.rkt"
@ -99,7 +100,11 @@
(namespace-require `(only (submod (file ,(path->string (resolved-module-path-name r6rs-lang-mod))) ikarus) with-implicit) (namespace-require `(only (submod (file ,(path->string (resolved-module-path-name r6rs-lang-mod))) ikarus) with-implicit)
ns) ns)
(define orig-eval (current-eval)) (define show? #f)
(define orig-eval (let ([e (current-eval)])
(lambda args
(when show? (pretty-write args))
(apply e args))))
(define (call-with-expressions path proc) (define (call-with-expressions path proc)
(call-with-input-file* (call-with-input-file*
@ -332,7 +337,7 @@
(with-handlers (#;[exn:fail? (lambda (exn) (with-handlers (#;[exn:fail? (lambda (exn)
(eprintf "ERROR: ~s\n" (exn-message exn)) (eprintf "ERROR: ~s\n" (exn-message exn))
(set! failed? #t))]) (set! failed? #t))])
((orig-eval 'compile-file) src dest))))) (time ((orig-eval 'compile-file) src dest))))))
(when failed? (when failed?
(raise-user-error 'make-boot "compilation failure(s)"))) (raise-user-error 'make-boot "compilation failure(s)")))

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

@ -13,6 +13,7 @@
"syntax-mode.rkt" "syntax-mode.rkt"
"constant.rkt" "constant.rkt"
"config.rkt" "config.rkt"
"rcd.rkt"
(only-in "record.rkt" (only-in "record.rkt"
do-$make-record-type do-$make-record-type
register-rtd-name! register-rtd-name!
@ -576,32 +577,7 @@
;; For Chez Scheme's legacy procedure ;; For Chez Scheme's legacy procedure
(struct-type-make-constructor rcd)] (struct-type-make-constructor rcd)]
[(rec-cons-desc? rcd) [(rec-cons-desc? rcd)
(define rtd (rec-cons-desc-rtd rcd)) (rcd->constructor rcd lookup-protocol)]))
(define ctr (struct-type-make-constructor rtd))
((record-constructor-generator rcd) ctr)]))
(define (record-constructor-generator rcd)
(define rtd (rec-cons-desc-rtd rcd))
(define p (rec-cons-desc-protocol rcd))
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info rtd))
(cond
[(not p) (lambda (ctr) ctr)]
[(rec-cons-desc-parent-rcd rcd)
=> (lambda (p-rcd)
(lambda (ctr)
(p ((record-constructor-generator p-rcd)
(lambda args1
(lambda args2
(apply ctr (append args1 args2))))))))]
[super
(define parent-p (lookup-protocol super))
(lambda (ctr)
(p (parent-p
(lambda args1
(lambda args2
(apply ctr (append args1 args2)))))))]
[else p]))
(define (make-record-type-descriptor name parent uid s? o? fields) (define (make-record-type-descriptor name parent uid s? o? fields)
(do-$make-record-type base-rtd parent name fields s? o? null #:uid uid)) (do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))

68
racket/src/cs/bootstrap/rcd.rkt Normal file
View File

@ -0,0 +1,68 @@
#lang racket/base
(require "scheme-struct.rkt"
(for-template racket/base))
(provide rcd->constructor
(struct-out rcd-info)
rcd->rcdi)
(define (rcd->constructor rcd lookup-protocol)
(define rtd (rec-cons-desc-rtd rcd))
(define ctr (struct-type-make-constructor rtd))
((record-constructor-generator rcd lookup-protocol) ctr))
(define (record-constructor-generator rcd lookup-protocol)
(define rtd (rec-cons-desc-rtd rcd))
(define p (rec-cons-desc-protocol rcd))
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info rtd))
(cond
[(not p) (lambda (ctr) ctr)]
[(rec-cons-desc-parent-rcd rcd)
=> (lambda (p-rcd)
(define p-gen (record-constructor-generator p-rcd lookup-protocol))
(and p-gen
(lambda (ctr)
(p (p-gen
(lambda args1
(lambda args2
(apply ctr (append args1 args2)))))))))]
[(and super (not lookup-protocol)) #f]
[super
(define parent-p (lookup-protocol super))
(lambda (ctr)
(p (parent-p
(lambda args1
(lambda args2
(apply ctr (append args1 args2)))))))]
[else p]))
;; ----------------------------------------
(struct rcd-info (rtd proto-expr base-rcdi init-cnt)
#:transparent)
(define (rcd->rcdi rcd)
(cond
[(rec-cons-desc-parent-rcd rcd)
=> (lambda (p-rcd)
(define p-rcdi (rcd->rcdi p-rcd))
(and p-rcdi
(let ()
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info (rec-cons-desc-rtd rcd)))
(define proto (rec-cons-desc-protocol rcd))
(rcd-info (rec-cons-desc-rtd rcd)
proto
p-rcdi
(+ init-cnt
(rcd-info-init-cnt p-rcdi))))))]
[else
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info (rec-cons-desc-rtd rcd)))
(define proto (rec-cons-desc-protocol rcd))
(and (not super)
(rcd-info (rec-cons-desc-rtd rcd)
proto
#f
init-cnt))]))

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

@ -23,7 +23,9 @@
make-record-constructor-descriptor make-record-constructor-descriptor
set-car! set-car!
set-cdr!) set-cdr!)
(submod "r6rs-lang.rkt" hash-pair)) (submod "r6rs-lang.rkt" hash-pair)
(for-syntax "scheme-struct.rkt"
"rcd.rkt"))
(provide (rename-out [s:define define] (provide (rename-out [s:define define]
[s:define define-threaded] [s:define define-threaded]
@ -364,16 +366,26 @@
(define-syntax (letrec* stx) (define-syntax (letrec* stx)
(syntax-case stx () (syntax-case stx ()
[(_ (clause ...) . body) [(_ (clause ...) . body)
(let loop ([clauses (syntax->list #'(clause ...))] [lets '()] [letrecs '()]) (let loop ([clauses (syntax->list #'(clause ...))] [lets '()] [letrecs '()] [macros '()] [rcds #hasheq()])
(cond (cond
[(null? clauses) [(null? clauses)
#`(let #,(reverse lets) #`(let #,(reverse lets)
(letrec #,(reverse letrecs) (letrec-syntaxes+values #,(for/list ([s (in-list macros)])
(syntax-case s ()
[[id rhs]
#'[(id) (lambda (stx) (quote-syntax rhs))]]))
#,(for/list ([s (in-list (reverse letrecs))])
(syntax-case s ()
[[id rhs]
#'[(id) rhs]]))
. body))] . body))]
[else [else
(syntax-case* (car clauses) ($primitive quote record-accessor record-predicate) (lambda (a b) (define (id-eq? a b) (eq? (syntax-e a) (syntax-e b)))
(eq? (syntax-e a) (syntax-case* (car clauses) ($primitive record-accessor record-predicate
(syntax-e b))) $make-record-constructor-descriptor
make-record-constructor-descriptor
r6rs:record-constructor
quote) id-eq?
[[id (($primitive _ record-accessor) 'rtd n)] [[id (($primitive _ record-accessor) 'rtd n)]
(and (struct-type? (syntax-e #'rtd)) (and (struct-type? (syntax-e #'rtd))
(integer? (syntax-e #'n))) (integer? (syntax-e #'n)))
@ -382,7 +394,9 @@
#`[id '#,a] #`[id '#,a]
(car clauses)) (car clauses))
lets) lets)
letrecs))] letrecs
macros
rcds))]
[[id (($primitive _ record-mutator) 'rtd n)] [[id (($primitive _ record-mutator) 'rtd n)]
(and (struct-type? (syntax-e #'rtd)) (and (struct-type? (syntax-e #'rtd))
(integer? (syntax-e #'n))) (integer? (syntax-e #'n)))
@ -391,7 +405,9 @@
#`[id '#,m] #`[id '#,m]
(car clauses)) (car clauses))
lets) lets)
letrecs))] letrecs
macros
rcds))]
[[id (($primitive _ record-predicate) 'rtd)] [[id (($primitive _ record-predicate) 'rtd)]
(struct-type? (syntax-e #'rtd)) (struct-type? (syntax-e #'rtd))
(let ([p (compile-time-record-predicate (syntax-e #'rtd))]) (let ([p (compile-time-record-predicate (syntax-e #'rtd))])
@ -399,9 +415,141 @@
#`[id '#,p] #`[id '#,p]
(car clauses)) (car clauses))
lets) lets)
letrecs))] letrecs
macros
rcds))]
[[id (($primitive _ r6rs:record-constructor) 'rcd)]
(rec-cons-desc? (syntax-e #'rcd))
(let ([c (rcd->constructor (syntax-e #'rcd) #f)])
(cond
[c (loop (cdr clauses) (cons #`[id #,c]
lets)
letrecs
macros
rcds)]
[else [else
(loop (cdr clauses) lets (cons (car clauses) letrecs))])]))])) (and (log-warning "couldn't inline ~s" (car clauses)) #f)
(loop (cdr clauses) lets (cons (car clauses) letrecs) macros rcds)]))]
[[id (($primitive _ mrcd)
'rtd
base
proc
. maybe-name)]
(and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd))
(eq? 'make-record-constructor-descriptor (syntax-e #'mrcd)))
(struct-type? (syntax-e #'rtd))
(or (not (syntax-e #'base))
(hash-ref rcds (syntax-e #'base) #f))
(immediate-procedure-expression? #'proc))
(let ([rtd (syntax-e #'rtd)]
[base-rcdi (and (syntax-e #'base)
(hash-ref rcds (syntax-e #'base) #f))])
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info rtd))
(when (and (not base-rcdi)
super)
(error "can't handle an rcd without a base rcd and with a parent record type"))
(define rdci (rcd-info rtd #'proc base-rcdi (+ init-cnt (if base-rcdi
(rcd-info-init-cnt base-rcdi)
0))))
(loop (cdr clauses)
lets
(cons #`[id (mrcd
'#,rtd
base
proc
. maybe-name)]
letrecs)
macros
(hash-set rcds (syntax-e #'id) rdci)))]
[[id (($primitive _ mrcd)
'rtd
'base-rcd
proc
. maybe-name)]
(and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd))
(eq? 'make-record-constructor-descriptor (syntax-e #'mrcd)))
(struct-type? (syntax-e #'rtd))
(rec-cons-desc? (syntax-e #'base-rcd))
(immediate-procedure-expression? #'proc))
(let ([rtd (syntax-e #'rtd)]
[base-rcdi (rcd->rcdi (syntax-e #'base-rcd))])
(unless base-rcdi
(error "can't handle this literal rcd: ~e" (syntax-e #'base-rcd)))
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
(struct-type-info rtd))
(define rdci (rcd-info rtd #'proc base-rcdi (+ init-cnt (rcd-info-init-cnt base-rcdi))))
(loop (cdr clauses)
lets
(cons #`[id (mrcd
'#,rtd
'base-rcd
proc
. maybe-name)]
letrecs)
macros
(hash-set rcds (syntax-e #'id) rdci)))]
[[id (($primitive _ r6rs:record-constructor) rcd-id)]
(and (identifier? #'rcd-id)
(hash-ref rcds (syntax-e #'rcd-id) #f))
(let ([rcdi (hash-ref rcds (syntax-e #'rcd-id))])
(define (rcdi->generator rcdi)
(define base-rcdi (rcd-info-base-rcdi rcdi))
(cond
[(not (rcd-info-proto-expr rcdi))
#`(lambda (ctr) ctr)]
[(not base-rcdi)
(rcd-info-proto-expr rcdi)]
[else
(with-syntax ([ctr (gensym 'ctr)]
[(p-arg ...) (for/list ([i (in-range (rcd-info-init-cnt base-rcdi))])
(gensym))]
[(c-arg ...) (for/list ([i (in-range (- (rcd-info-init-cnt rcdi)
(rcd-info-init-cnt base-rcdi)))])
(gensym))])
#`(lambda (ctr)
(#,(rcd-info-proto-expr rcdi)
(#,(rcdi->generator base-rcdi)
(lambda (p-arg ...)
(lambda (c-arg ...)
(ctr p-arg ... c-arg ...)))))))]))
(define c (struct-type-make-constructor (rcd-info-rtd rcdi)))
(loop (cdr clauses)
lets
(cons #`[id (#,(rcdi->generator rcdi) #,c)]
letrecs)
macros
rcds))]
[[id (($primitive _ r6rs:record-constructor) _)]
(and (log-warning "couldn't simplify ~s" (car clauses))
#f)
(void)]
[[id (($primitive _ mrcd) . _)]
(and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd))
(eq? 'make-record-constructor-descriptor (syntax-e #'mrcd)))
(log-warning "couldn't recognize ~s" (car clauses))
#f)
(void)]
[else
(loop (cdr clauses) lets (cons (car clauses) letrecs) macros rcds)])]))]))
(define-for-syntax (immediate-procedure-expression? s)
(syntax-case s ()
[(id . _)
(and (identifier? #'id)
(or (eq? (syntax-e #'id) 'lambda)
(eq? (syntax-e #'id) 'case-lambda)))]
[_ #f]))
(define-syntax (with-inline-cache stx)
(syntax-case stx ()
[(_ expr)
#`(let ([b #,(mcons #f #f)])
(or (mcar b)
(let ([r expr])
(set-mcar! b r)
r)))]))
(define-syntax (s:parameterize stx) (define-syntax (s:parameterize stx)
(syntax-case stx () (syntax-case stx ()
@ -582,16 +730,20 @@
(define vector-for-each (define vector-for-each
(case-lambda (case-lambda
[(proc vec) [(proc vec)
(for-each proc (vector->list vec))] (for ([e (in-vector vec)])
(proc e))]
[(proc vec1 vec2) [(proc vec1 vec2)
(for-each proc (vector->list vec1) (vector->list vec2))] (for ([e1 (in-vector vec1)]
[e2 (in-vector vec2)])
(proc e1 e2))]
[(proc . vecs) [(proc . vecs)
(apply for-each proc (map vector->list vecs))])) (apply for-each proc (map vector->list vecs))]))
(define vector-map (define vector-map
(case-lambda (case-lambda
[(proc vec) [(proc vec)
(list->vector (map proc (vector->list vec)))] (for/vector #:length (vector-length vec) ([e (in-vector vec)])
(proc e))]
[(proc . vecs) [(proc . vecs)
(list->vector (apply map proc (map vector->list vecs)))])) (list->vector (apply map proc (map vector->list vecs)))]))