speed up Chez Scheme bootstrap a little
Recognize constructor patterns to avoid some indirections.
This commit is contained in:
Matthew Flatt
parent
f0314ddad7
commit
3235f648fb
|
|
@ -2,6 +2,7 @@
|
|||
(require racket/runtime-path
|
||||
racket/match
|
||||
racket/file
|
||||
racket/pretty
|
||||
(only-in "r6rs-lang.rkt"
|
||||
optimize-level)
|
||||
(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)
|
||||
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)
|
||||
(call-with-input-file*
|
||||
|
|
@ -332,7 +337,7 @@
|
|||
(with-handlers (#;[exn:fail? (lambda (exn)
|
||||
(eprintf "ERROR: ~s\n" (exn-message exn))
|
||||
(set! failed? #t))])
|
||||
((orig-eval 'compile-file) src dest)))))
|
||||
(time ((orig-eval 'compile-file) src dest))))))
|
||||
(when failed?
|
||||
(raise-user-error 'make-boot "compilation failure(s)")))
|
||||
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
"syntax-mode.rkt"
|
||||
"constant.rkt"
|
||||
"config.rkt"
|
||||
"rcd.rkt"
|
||||
(only-in "record.rkt"
|
||||
do-$make-record-type
|
||||
register-rtd-name!
|
||||
|
|
@ -576,32 +577,7 @@
|
|||
;; For Chez Scheme's legacy procedure
|
||||
(struct-type-make-constructor rcd)]
|
||||
[(rec-cons-desc? rcd)
|
||||
(define rtd (rec-cons-desc-rtd rcd))
|
||||
(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]))
|
||||
(rcd->constructor rcd lookup-protocol)]))
|
||||
|
||||
(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))
|
||||
|
|
|
|||
68
racket/src/cs/bootstrap/rcd.rkt
Normal file
68
racket/src/cs/bootstrap/rcd.rkt
Normal 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))]))
|
||||
|
|
@ -23,7 +23,9 @@
|
|||
make-record-constructor-descriptor
|
||||
set-car!
|
||||
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]
|
||||
[s:define define-threaded]
|
||||
|
|
@ -364,16 +366,26 @@
|
|||
(define-syntax (letrec* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (clause ...) . body)
|
||||
(let loop ([clauses (syntax->list #'(clause ...))] [lets '()] [letrecs '()])
|
||||
(let loop ([clauses (syntax->list #'(clause ...))] [lets '()] [letrecs '()] [macros '()] [rcds #hasheq()])
|
||||
(cond
|
||||
[(null? clauses)
|
||||
#`(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))]
|
||||
[else
|
||||
(syntax-case* (car clauses) ($primitive quote record-accessor record-predicate) (lambda (a b)
|
||||
(eq? (syntax-e a)
|
||||
(syntax-e b)))
|
||||
(define (id-eq? a b) (eq? (syntax-e a) (syntax-e b)))
|
||||
(syntax-case* (car clauses) ($primitive record-accessor record-predicate
|
||||
$make-record-constructor-descriptor
|
||||
make-record-constructor-descriptor
|
||||
r6rs:record-constructor
|
||||
quote) id-eq?
|
||||
[[id (($primitive _ record-accessor) 'rtd n)]
|
||||
(and (struct-type? (syntax-e #'rtd))
|
||||
(integer? (syntax-e #'n)))
|
||||
|
|
@ -382,7 +394,9 @@
|
|||
#`[id '#,a]
|
||||
(car clauses))
|
||||
lets)
|
||||
letrecs))]
|
||||
letrecs
|
||||
macros
|
||||
rcds))]
|
||||
[[id (($primitive _ record-mutator) 'rtd n)]
|
||||
(and (struct-type? (syntax-e #'rtd))
|
||||
(integer? (syntax-e #'n)))
|
||||
|
|
@ -391,7 +405,9 @@
|
|||
#`[id '#,m]
|
||||
(car clauses))
|
||||
lets)
|
||||
letrecs))]
|
||||
letrecs
|
||||
macros
|
||||
rcds))]
|
||||
[[id (($primitive _ record-predicate) 'rtd)]
|
||||
(struct-type? (syntax-e #'rtd))
|
||||
(let ([p (compile-time-record-predicate (syntax-e #'rtd))])
|
||||
|
|
@ -399,9 +415,141 @@
|
|||
#`[id '#,p]
|
||||
(car clauses))
|
||||
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
|
||||
(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))])]))]))
|
||||
(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)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -582,16 +730,20 @@
|
|||
(define vector-for-each
|
||||
(case-lambda
|
||||
[(proc vec)
|
||||
(for-each proc (vector->list vec))]
|
||||
(for ([e (in-vector vec)])
|
||||
(proc e))]
|
||||
[(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)
|
||||
(apply for-each proc (map vector->list vecs))]))
|
||||
|
||||
(define vector-map
|
||||
(case-lambda
|
||||
[(proc vec)
|
||||
(list->vector (map proc (vector->list vec)))]
|
||||
(for/vector #:length (vector-length vec) ([e (in-vector vec)])
|
||||
(proc e))]
|
||||
[(proc . vecs)
|
||||
(list->vector (apply map proc (map vector->list vecs)))]))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user