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

cs: cooperate with improved cross-library inlining

Browse Source 
An improvement to Chez Scheme allows more function from the Rumble and
other built-in layers to be inlined into compiled Racket code, and a
new `$app/no-inline` primitive enables improved control over how slow
paths are integrated.
This commit is contained in:
Matthew Flatt 2020-01-18 09:45:41 -07:00
parent b9c78fccd8
commit 848d2148b0
13 changed files with 240 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.6.0.3")
(define version "7.6.0.4")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

@ -539,3 +539,55 @@ configuration:
Effectiveness: Avoids improvement to stack traces, but also avoids
increases load time and memory use of Racket programs by as much as
50%.
Inlining Expectations
---------------------
Chez Scheme will inline small Rumble functions as long as the inlined
function body refers only to primitives and other identifiers that are
explicitly defined in the Rumble library body. The "explicily defined"
part can be tricky, particularly since inling will consider the
function body after other inlining is already applied. For example,
given
(define (list? v)
(or (null? v)
(and (pair? v)
(slow-list? v))))
(define (slow-list? v)
(let loop ([v v] [depth 0])
....))
then `list?` probably will not be inlined, because the call to
`slow-list?` within `list?` is likely to be inlined, so that `list?`
ends up calling the `loop` function nested within `slow-list?` (and
`loop` is not defined at the level of the library body).
The `$app/no-inline` primitive is useful to prevent unproductive
inlining, particularly to enable other, productive inlining. For
example,
(define (list? v)
(or (null? v)
(and (pair? v)
(#%$app/no-inline slow-list? v))))
is likely to make `list?` inlinable, since the reference to
`slow-list?` is preserved.
Chez Scheme will inline small Rumble functions independent of the
amount of inlining that has already happened at the call site of the
Rumble function. To prevent code explosion and endless inlining
cycles, however, it will not perform further inlining of a Rumble
function that is referenced by code introduced by inlining another
Rumble function.
Using a macro to force inlining can be ok, but that technique should
be used sparingly. Note that a reference to a primitive in a macro
will be compiled as a safe reference to the primitive, since the
conversion of a primitive reference to unsafe or not based on
`(optimize-level)` is an expansion-time operation. So, macros that are
meant to expand to uses of unsafe operations should refer to the
operations using `#3%`; beware that such a reference will stay unsafe,
even if `UNSAFE_COMP` is disabled in the makefile.

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

@ -174,6 +174,8 @@
[`(eval-when ,_ (define ,m . ,rhs))
(when (define-for-syntax? m)
(orig-eval `(begin-for-syntax (define ,m . ,rhs))))]
[`(define-flags . ,_)
(orig-eval e)]
[_ (void)])))
(set-current-expand-set-callback!

3
racket/src/cs/bootstrap/primdata.rkt
View File

@ -75,8 +75,7 @@
sigs
(map sig->interface sigs)))]))])
(loop))))))
(values flags->bits
(lambda () (list->vector (hash-keys priminfos)))
(values (lambda () (list->vector (hash-keys priminfos)))
(lambda (sym) (hash-ref priminfos sym #f))))
(define (sig->interface sig)

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

@ -1,5 +1,6 @@
#lang racket/base
(require (for-syntax racket/base)
(require (for-syntax racket/base
racket/match)
(prefix-in r: racket/include)
racket/fixnum
racket/vector
@ -42,7 +43,7 @@
letrec*
putprop getprop remprop
$sputprop $sgetprop $sremprop
prim-mask
define-flags
$primitive
$tc $tc-field $thread-tc
enumerate
@ -591,15 +592,33 @@
(lambda lhs (values . flat-lhs)))])]))])
#'(let-values ([lhs rhs] ...) body ...))]))
(define-values (prim-flags->bits primvec get-priminfo)
(define-values (primvec get-priminfo)
(get-primdata $sputprop scheme-dir))
(define-syntax prim-mask
(syntax-rules (or)
[(_ (or flag ...))
(prim-flags->bits '(flag ...))]
[(_ flag)
(prim-flags->bits '(flag))]))
(begin-for-syntax
(define (make-flags->bits specs)
(define bits
(for/fold ([bits #hasheq()]) ([spec (in-list specs)])
(define (get-val v)
(if (number? v) v (hash-ref bits v)))
(match spec
[`(,name (or ,vals ...))
(hash-set bits name (apply bitwise-ior (map get-val vals)))]
[`(,name ,val)
(hash-set bits name (get-val val))])))
(lambda (flags)
(apply bitwise-ior (for/list ([flag (in-list flags)])
(hash-ref bits flag))))))
(define-syntax (define-flags stx)
(syntax-case stx ()
[(_ name spec ...)
#'(define-syntax name
(let ([flags->bits (make-flags->bits '(spec ...))])
(lambda (stx)
(syntax-case stx (or)
[(_ . flags)
(flags->bits 'flags)]))))]))
(define-syntax $primitive
(syntax-rules ()

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

3
racket/src/cs/rumble/begin0.ss
View File

@ -11,6 +11,5 @@
(lambda (l apply?)
expr ...
(if apply?
(#%apply values l)
(#3%apply values l)
l)))]))

102
racket/src/cs/rumble/box.ss
View File

@ -17,7 +17,7 @@
(define (unbox b)
(if (#%box? b)
(#3%unbox b)
(impersonate-unbox b)))
(#%$app/no-inline impersonate-unbox b)))
(define (unsafe-unbox b)
;; must handle impersonators
@ -26,7 +26,10 @@
(define/who (unbox* b)
(if (#%box? b)
(#3%unbox b)
(bad-box*-op who #f b)))
(#%$app/no-inline bad-unbox* b)))
(define (bad-unbox* b)
(bad-box*-op 'unbox* #f b))
(define (bad-box*-op who set? b)
(raise-argument-error who
@ -38,7 +41,7 @@
(define (set-box! b v)
(if (#%mutable-box? b)
(#3%set-box! b v)
(impersonate-set-box! b v)))
(#%$app/no-inline impersonate-set-box! b v)))
(define (unsafe-set-box! b v)
;; must handle impersonators
@ -47,7 +50,10 @@
(define/who (set-box*! b v)
(if (#%mutable-box? b)
(#3%set-box! b v)
(bad-box*-op who #t b)))
(#%$app/no-inline bad-set-box*! b)))
(define (bad-set-box*! b)
(bad-box*-op 'set-box*! #t b))
;; in schemified:
(define (unbox/check-undefined b name)
@ -83,53 +89,51 @@
(make-box-impersonator val b props ref set)))
(define (impersonate-unbox orig)
(pariah
(if (and (impersonator? orig)
(#%box? (impersonator-val orig)))
(let loop ([o orig])
(cond
[(#%box? o) (#%unbox o)]
[(box-chaperone? o)
(let* ([val (loop (impersonator-next o))]
[new-val (|#%app| (box-chaperone-ref o) o val)])
(unless (chaperone-of? new-val val)
(raise-arguments-error 'unbox
"chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val
"original result" val))
new-val)]
[(box-impersonator? o)
(let ([val (loop (impersonator-next o))])
((box-impersonator-ref o) o val))]
[else (loop (impersonator-next o))]))
;; Let primitive report the error:
(#2%unbox orig))))
(if (and (impersonator? orig)
(#%box? (impersonator-val orig)))
(let loop ([o orig])
(cond
[(#%box? o) (#%unbox o)]
[(box-chaperone? o)
(let* ([val (loop (impersonator-next o))]
[new-val (|#%app| (box-chaperone-ref o) o val)])
(unless (chaperone-of? new-val val)
(raise-arguments-error 'unbox
"chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val
"original result" val))
new-val)]
[(box-impersonator? o)
(let ([val (loop (impersonator-next o))])
((box-impersonator-ref o) o val))]
[else (loop (impersonator-next o))]))
;; Let primitive report the error:
(#2%unbox orig)))
(define (impersonate-set-box! orig val)
(pariah
(cond
[(not (and (impersonator? orig)
(mutable-box? (impersonator-val orig))))
;; Let primitive report the error:
(#2%set-box! orig val)]
[else
(let loop ([o orig] [val val])
(cond
[(#%box? o) (#2%set-box! o val)]
[else
(let ([next (impersonator-next o)])
(cond
[(box-chaperone? o)
(let ([new-val (|#%app| (box-chaperone-set o) next val)])
(unless (chaperone-of? new-val val)
(raise-arguments-error 'set-box!
"chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val
"original result" val))
(loop next new-val))]
[(box-impersonator? o)
(loop next ((box-impersonator-set o) next val))]
[else (loop next val)]))]))])))
(cond
[(not (and (impersonator? orig)
(mutable-box? (impersonator-val orig))))
;; Let primitive report the error:
(#2%set-box! orig val)]
[else
(let loop ([o orig] [val val])
(cond
[(#%box? o) (#2%set-box! o val)]
[else
(let ([next (impersonator-next o)])
(cond
[(box-chaperone? o)
(let ([new-val (|#%app| (box-chaperone-set o) next val)])
(unless (chaperone-of? new-val val)
(raise-arguments-error 'set-box!
"chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val
"original result" val))
(loop next new-val))]
[(box-impersonator? o)
(loop next ((box-impersonator-set o) next val))]
[else (loop next val)]))]))]))
(define (set-box-impersonator-hash!)
(record-type-hash-procedure (record-type-descriptor box-chaperone)

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

@ -23,6 +23,9 @@
"received" e2))
(define (impersonate-ref acc rtd pos orig record-name field-name)
(#%$app/no-inline do-impersonate-ref acc rtd pos orig record-name field-name))
(define (do-impersonate-ref acc rtd pos orig record-name field-name)
(impersonate-struct-or-property-ref acc rtd (cons rtd pos) orig record-name field-name))
(define (impersonate-struct-or-property-ref acc rtd key orig record-name field-name)
@ -71,6 +74,9 @@
orig)]))
(define (impersonate-set! set rtd pos abs-pos orig a record-name field-name)
(#%$app/no-inline do-impersonate-set! set rtd pos abs-pos orig a record-name field-name))
(define (do-impersonate-set! set rtd pos abs-pos orig a record-name field-name)
(cond
[(and (impersonator? orig)
(record? (impersonator-val orig) rtd))

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

@ -15,7 +15,7 @@
#'(let ([arg tmp] ...)
(if guard
op
(orig-id arg ...)))]
(#3%$app/no-inline orig-id arg ...)))]
[(_ . args)
#'(orig-id . args)]
[_ #'orig-id])))]))

5
racket/src/cs/rumble/procedure.ss
View File

@ -77,11 +77,10 @@
(let ([tmp f])
(if (#%procedure? tmp)
tmp
(slow-extract-procedure tmp n-args))))
(#3%$app/no-inline slow-extract-procedure tmp n-args))))
(define (slow-extract-procedure f n-args)
(pariah ; => don't inline enclosing procedure
(do-extract-procedure f f n-args #f not-a-procedure)))
(do-extract-procedure f f n-args #f not-a-procedure))
;; Returns a host-Scheme procedure, but first checks arity so that
;; checking and reporting use the right top-level function, and

179
racket/src/cs/rumble/vector.ss
View File

@ -142,7 +142,7 @@
(define (vector-length vec)
(if (#%vector? vec)
(#3%vector-length vec)
(impersonate-vector-length vec)))
(#%$app/no-inline impersonate-vector-length vec)))
(define (unsafe-vector-length vec)
(vector-length vec))
@ -150,41 +150,43 @@
(define (vector*-length vec)
(if (#%vector? vec)
(#3%vector-length vec)
(bad-vector*-for-length vec)))
(#%$app/no-inline bad-vector*-for-length vec)))
(define (bad-vector*-for-length vec)
(raise-argument-error 'vector*-length "(and/c vector? (not impersonator?))" vec))
(define (impersonate-vector-length vec)
(pariah
(if (and (impersonator? vec)
(#%vector? (impersonator-val vec)))
(cond
[(vector-unsafe-chaperone? vec)
(#%vector-length (vector-unsafe-chaperone-vec vec))]
[(vector-unsafe-impersonator? vec)
(#%vector-length (vector-unsafe-impersonator-vec vec))]
[else
(#%vector-length (impersonator-val vec))])
;; Let primitive report the error:
(#2%vector-length vec))))
(if (and (impersonator? vec)
(#%vector? (impersonator-val vec)))
(cond
[(vector-unsafe-chaperone? vec)
(#%vector-length (vector-unsafe-chaperone-vec vec))]
[(vector-unsafe-impersonator? vec)
(#%vector-length (vector-unsafe-impersonator-vec vec))]
[else
(#%vector-length (impersonator-val vec))])
;; Let primitive report the error:
(#2%vector-length vec)))
;; ----------------------------------------
(define (vector-ref vec idx)
(if (#%$vector-ref-check? vec idx)
(#3%vector-ref vec idx)
(impersonate-vector-ref vec idx)))
(#%$app/no-inline impersonate-vector-ref vec idx)))
(define (unsafe-vector-ref vec idx)
(if (#%vector? vec)
(#3%vector-ref vec idx)
(impersonate-vector-ref vec idx)))
(#%$app/no-inline impersonate-vector-ref vec idx)))
(define/who (vector*-ref vec idx)
(if (#%$vector-ref-check? vec idx)
(#3%vector-ref vec idx)
(bad-vector*-op who #f vec idx)))
(#%$app/no-inline bad-vector*-ref vec idx)))
(define (bad-vector*-ref vec idx)
(bad-vector*-op 'vector*-ref #f vec idx))
(define (bad-vector*-op who set? vec idx)
(cond
@ -198,93 +200,94 @@
(check-range who "vector" vec idx #f (fx- (#%vector-length vec) 1)))
(define (impersonate-vector-ref orig idx)
(pariah
(if (and (impersonator? orig)
(#%vector? (impersonator-val orig)))
(let loop ([o orig])
(cond
[(#%vector? o) (#2%vector-ref o idx)]
[(vector-chaperone? o)
(let* ([o-next (impersonator-next o)]
[val (loop o-next)]
[new-val (if (vector*-chaperone? o)
(|#%app| (vector-chaperone-ref o) orig o-next idx val)
(|#%app| (vector-chaperone-ref o) o-next idx val))])
(unless (chaperone-of? new-val val)
(raise-arguments-error 'vector-ref
"chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val
"original result" val))
new-val)]
[(vector-impersonator? o)
(let* ([o-next (impersonator-next o)]
[val (loop o-next)])
(if (vector*-impersonator? o)
(|#%app| (vector-impersonator-ref o) orig o-next idx val)
(|#%app| (vector-impersonator-ref o) o-next idx val)))]
[(vector-unsafe-impersonator? o)
(vector-ref (vector-unsafe-impersonator-vec o) idx)]
[(vector-unsafe-chaperone? o)
(vector-ref (vector-unsafe-chaperone-vec o) idx)]
[else (loop (impersonator-next o))]))
;; Let primitive report the error:
(#2%vector-ref orig idx))))
(if (and (impersonator? orig)
(#%vector? (impersonator-val orig)))
(let loop ([o orig])
(cond
[(#%vector? o) (#2%vector-ref o idx)]
[(vector-chaperone? o)
(let* ([o-next (impersonator-next o)]
[val (loop o-next)]
[new-val (if (vector*-chaperone? o)
(|#%app| (vector-chaperone-ref o) orig o-next idx val)
(|#%app| (vector-chaperone-ref o) o-next idx val))])
(unless (chaperone-of? new-val val)
(raise-arguments-error 'vector-ref
"chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val
"original result" val))
new-val)]
[(vector-impersonator? o)
(let* ([o-next (impersonator-next o)]
[val (loop o-next)])
(if (vector*-impersonator? o)
(|#%app| (vector-impersonator-ref o) orig o-next idx val)
(|#%app| (vector-impersonator-ref o) o-next idx val)))]
[(vector-unsafe-impersonator? o)
(vector-ref (vector-unsafe-impersonator-vec o) idx)]
[(vector-unsafe-chaperone? o)
(vector-ref (vector-unsafe-chaperone-vec o) idx)]
[else (loop (impersonator-next o))]))
;; Let primitive report the error:
(#2%vector-ref orig idx)))
;; ----------------------------------------
(define (vector-set! vec idx val)
(if (#%$vector-set!-check? vec idx)
(#3%vector-set! vec idx val)
(impersonate-vector-set! vec idx val)))
(#%$app/no-inline impersonate-vector-set! vec idx val)))
(define (unsafe-vector-set! vec idx val)
(if (#%vector? vec)
(#3%vector-set! vec idx val)
(impersonate-vector-set! vec idx val)))
(#%$app/no-inline impersonate-vector-set! vec idx val)))
(define/who (vector*-set! vec idx val)
(if (#%$vector-set!-check? vec idx)
(#3%vector-set! vec idx val)
(bad-vector*-op who #t vec idx)))
(#%$app/no-inline bad-vector*-set! vec idx val)))
(define (bad-vector*-set! vec idx val)
(bad-vector*-op 'vector*-set! #t vec idx))
(define (impersonate-vector-set! orig idx val)
(pariah
(cond
[(not (and (impersonator? orig)
(mutable-vector? (impersonator-val orig))))
;; Let primitive report the error:
(#2%vector-set! orig idx val)]
[(or (not (exact-nonnegative-integer? idx))
(>= idx (vector-length (impersonator-val orig))))
;; Let primitive report the index error:
(#2%vector-set! (impersonator-val orig) idx val)]
[else
(let loop ([o orig] [val val])
(cond
[(#%vector? o) (#2%vector-set! o idx val)]
[else
(let ([next (impersonator-next o)])
(cond
[(vector-chaperone? o)
(let ([new-val (if (vector*-chaperone? o)
(|#%app| (vector-chaperone-set o) orig next idx val)
(|#%app| (vector-chaperone-set o) next idx val))])
(unless (chaperone-of? new-val val)
(raise-arguments-error 'vector-set!
"chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val
"original result" val))
(loop next new-val))]
[(vector-impersonator? o)
(loop next
(if (vector*-impersonator? o)
(|#%app| (vector-impersonator-set o) orig next idx val)
(|#%app| (vector-impersonator-set o) next idx val)))]
[(vector-unsafe-impersonator? o)
(#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)]
[(vector-unsafe-chaperone? o)
(#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)]
[else (loop next val)]))]))])))
(cond
[(not (and (impersonator? orig)
(mutable-vector? (impersonator-val orig))))
;; Let primitive report the error:
(#2%vector-set! orig idx val)]
[(or (not (exact-nonnegative-integer? idx))
(>= idx (vector-length (impersonator-val orig))))
;; Let primitive report the index error:
(#2%vector-set! (impersonator-val orig) idx val)]
[else
(let loop ([o orig] [val val])
(cond
[(#%vector? o) (#2%vector-set! o idx val)]
[else
(let ([next (impersonator-next o)])
(cond
[(vector-chaperone? o)
(let ([new-val (if (vector*-chaperone? o)
(|#%app| (vector-chaperone-set o) orig next idx val)
(|#%app| (vector-chaperone-set o) next idx val))])
(unless (chaperone-of? new-val val)
(raise-arguments-error 'vector-set!
"chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val
"original result" val))
(loop next new-val))]
[(vector-impersonator? o)
(loop next
(if (vector*-impersonator? o)
(|#%app| (vector-impersonator-set o) orig next idx val)
(|#%app| (vector-impersonator-set o) next idx val)))]
[(vector-unsafe-impersonator? o)
(#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)]
[(vector-unsafe-chaperone? o)
(#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)]
[else (loop next val)]))]))]))
;; ----------------------------------------

2
racket/src/racket/src/schvers.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 6
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x