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

improve cross-library inlining

Browse Source 
Allow a library-defined function to be inlined when the inlined
expressions refer to other library-defined functions. Since the
library function's body may already have inlined calls, don't allow
further inlining of calls within the inlined code.

This commit also adds `$app/no-inline`, which can be used to prevent
inlining of a function. For consumers other than Racket on Chez
Scheme, probably it would make sense to provide a nicer-looking
syntactic form that expands to use the internal `$app/no-inline`
function.

original commit: 628d57e1bd2e658aad4da97a3e85bda72c38f6ab
This commit is contained in:
Matthew Flatt 2020-01-17 17:13:24 -07:00
parent 45381612b2
commit 6020b944ef
14 changed files with 204 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point # # no changes should be needed below this point #
############################################################################### ###############################################################################
Version=csv9.5.3.12 Version=csv9.5.3.13
Include=boot/$m Include=boot/$m
PetiteBoot=boot/$m/petite.boot PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot SchemeBoot=boot/$m/scheme.boot

25
s/base-lang.ss
View File

@ -18,7 +18,7 @@
sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src
make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags
preinfo-lambda-flags-set! preinfo-lambda-libspec preinfo-lambda-flags-set! preinfo-lambda-libspec
make-preinfo-call preinfo-call? preinfo-call-check? make-preinfo-call preinfo-call? preinfo-call-flags preinfo-call-check? preinfo-call-can-inline?
prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set! prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set!
prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex* prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
target-fixnum? target-bignum?) target-fixnum? target-bignum?)
@ -185,17 +185,23 @@
[(src sexpr libspec name flags) ((pargs->new src sexpr) libspec name flags)])))) [(src sexpr libspec name flags) ((pargs->new src sexpr) libspec name flags)]))))
(define-record-type preinfo-call (define-record-type preinfo-call
(nongenerative #{preinfo-call e23pkvo5btgapnzomqgegm-7}) (nongenerative #{preinfo-call e23pkvo5btgapnzomqgegm-8})
(parent preinfo) (parent preinfo)
(sealed #t) (sealed #t)
(fields check?) (fields flags)
(protocol (protocol
(lambda (pargs->new) (lambda (pargs->new)
(case-lambda (case-lambda
[() ((pargs->new) #t)] [() ((pargs->new) (preinfo-call-mask))]
[(src) ((pargs->new src) #t)] [(src) ((pargs->new src) (preinfo-call-mask))]
[(src sexpr) ((pargs->new src sexpr) #t)] [(src sexpr) ((pargs->new src sexpr) (preinfo-call-mask))]
[(src sexpr check?) ((pargs->new src sexpr) check?)])))) [(src sexpr flags) ((pargs->new src sexpr) flags)]))))
(define (preinfo-call-check? preinfo)
(not (all-set? (preinfo-call-mask unchecked) (preinfo-call-flags preinfo))))
(define (preinfo-call-can-inline? preinfo)
(not (all-set? (preinfo-call-mask no-inline) (preinfo-call-flags preinfo))))
; language of foreign types ; language of foreign types
(define-language Ltype (define-language Ltype
@ -242,7 +248,8 @@
(convention (conv)) (convention (conv))
(maybe-string (name)) (maybe-string (name))
(symbol (sym type)) (symbol (sym type))
(primref (pr))) (primref (pr))
(list (exts)))
(Expr (e body rtd-expr) (Expr (e body rtd-expr)
pr pr
(moi) (moi)
@ -262,7 +269,7 @@
(record rtd rtd-expr e* ...) (record rtd rtd-expr e* ...)
(record-ref rtd type index e) (record-ref rtd type index e)
(record-set! rtd type index e1 e2) (record-set! rtd type index e1 e2)
(cte-optimization-loc box e) (cte-optimization-loc box e exts)
(foreign (conv* ...) name e (arg-type* ...) result-type) (foreign (conv* ...) name e (arg-type* ...) result-type)
(fcallable (conv* ...) e (arg-type* ...) result-type) (fcallable (conv* ...) e (arg-type* ...) result-type)
(profile src) => (profile) (profile src) => (profile)

7
s/cmacros.ss
View File

@ -328,7 +328,7 @@
[(_ foo e1 e2) e1] ... [(_ foo e1 e2) e1] ...
[(_ bar e1 e2) e2]))))]))) [(_ bar e1 e2) e2]))))])))
(define-constant scheme-version #x0905030C) (define-constant scheme-version #x0905030D)
(define-syntax define-machine-types (define-syntax define-machine-types
(lambda (x) (lambda (x)
@ -1662,6 +1662,11 @@
(single-valued #b1000000000) (single-valued #b1000000000)
) )
(define-flags preinfo-call-mask
(unchecked #b01)
(no-inline #b10)
)
(define-syntax define-flag-field (define-syntax define-flag-field
(lambda (exp) (lambda (exp)
(syntax-case exp () (syntax-case exp ()

5
s/compile.ss
View File

@ -1185,14 +1185,15 @@
(lambda (node) (lambda (node)
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node) (nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
(let ([exts ($build-library-exts dl* dv*)])
(fold-right (fold-right
(lambda (dl db dv body) (lambda (dl db dv body)
(if dl (if dl
`(seq ,(build-primcall '$set-top-level-value! `(quote ,dl) `(seq ,(build-primcall '$set-top-level-value! `(quote ,dl)
`(cte-optimization-loc ,db (ref #f ,dv))) `(cte-optimization-loc ,db (ref #f ,dv) ,exts))
,body) ,body)
body)) body))
(build-void) dl* db* dv*)]))) (build-void) dl* db* dv*))])))
(define make-patch-env (define make-patch-env
(lambda (cluster*) (lambda (cluster*)

144
s/cp0.ss
View File

@ -878,8 +878,9 @@
($unbound-object? obj) ($unbound-object? obj)
(record-type-descriptor? obj)))) (record-type-descriptor? obj))))
(define externally-inlinable? ;; Returns #f if the clause is not externally inlinable
(lambda (clause) (define externally-inlinable
(lambda (clause exts)
(call/cc (call/cc
(lambda (exit) (lambda (exit)
(define bump! (define bump!
@ -887,6 +888,14 @@
(lambda () (lambda ()
(set! size (fx+ size 1)) (set! size (fx+ size 1))
(when (fx> size score-limit) (exit #f))))) (when (fx> size score-limit) (exit #f)))))
(define find-ext
(lambda (x)
(let loop ([exts exts])
(cond
[(null? exts) #f]
[(eq? (prelex-name x) (prelex-name (caar exts)))
(cdar exts)]
[else (loop (cdr exts))]))))
(define (ids->do-clause ids) (define (ids->do-clause ids)
(rec do-clause (rec do-clause
(lambda (clause) (lambda (clause)
@ -894,58 +903,72 @@
(rec do-expr (rec do-expr
(lambda (e) (lambda (e)
(nanopass-case (Lsrc Expr) e (nanopass-case (Lsrc Expr) e
[(quote ,d) (if (okay-to-copy? d) (bump!) (exit #f))] [(quote ,d) (if (okay-to-copy? d) (begin (bump!) e) (exit #f))]
[(moi) (bump!)] [(moi) (bump!) e]
[,pr (bump!)] [,pr (bump!) e]
[(ref ,maybe-src ,x) (unless (memq x ids) (exit #f)) (bump!)] [(ref ,maybe-src ,x) (cond
[(seq ,[do-expr : e1] ,[do-expr : e2]) (void)] [(memq x ids) (bump!) e]
[(if ,[do-expr : e1] ,[do-expr : e2] ,[do-expr : e3]) (void)] [(find-ext x)
=> (lambda (label)
(bump!)
(let ([preinfo (make-preinfo-call #f #f (preinfo-call-mask unchecked no-inline))])
(build-primcall preinfo 3 '$top-level-value (list `(quote ,label)))))]
[else
(exit #f)])]
[(seq ,[do-expr : e1] ,[do-expr : e2]) `(seq ,e1 ,e2)]
[(if ,[do-expr : e1] ,[do-expr : e2] ,[do-expr : e3]) `(if ,e1 ,e2 ,e3)]
[(set! ,maybe-src ,x ,e) [(set! ,maybe-src ,x ,e)
(unless (memq x ids) (exit #f)) (unless (memq x ids) (exit #f))
(bump!) (bump!)
(do-expr e)] (do-expr e)]
[(call ,preinfo ,e ,e* ...) [(call ,preinfo ,e ,e* ...)
; reject calls to gensyms, since they might represent library exports, ; reject calls to gensyms, since they might represent library exports,
; and we have no way to set up the required invoke dependencies ; and we have no way to set up the required invoke dependencies, unless
; we're not emiting invoke dependencies anyway
(when (and (nanopass-case (Lsrc Expr) e (when (and (nanopass-case (Lsrc Expr) e
[,pr (eq? (primref-name pr) '$top-level-value)] [,pr (eq? (primref-name pr) '$top-level-value)]
[else #f]) [else #f])
(= (length e*) 1) (= (length e*) 1)
(cp0-constant? gensym? (car e*))) (cp0-constant? gensym? (car e*))
(not (expand-omit-library-invocations)))
(exit #f)) (exit #f))
(bump!) (bump!)
(do-expr e) `(call ,preinfo ,(do-expr e) ,(map do-expr e*) ...)]
(for-each do-expr e*)]
[(case-lambda ,preinfo ,cl* ...) [(case-lambda ,preinfo ,cl* ...)
(bump!) (bump!)
(for-each (ids->do-clause ids) cl*)] `(case-lambda ,preinfo ,(map (ids->do-clause ids) cl*) ...)]
[(letrec ([,x* ,e*] ...) ,body) [(letrec ([,x* ,e*] ...) ,body)
(bump!) (bump!)
(safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*)) (safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*))
(let ([do-expr (ids->do-expr (append x* ids))]) (let ([do-expr (ids->do-expr (append x* ids))])
(for-each do-expr e*) `(letrec ([,x* ,(map do-expr e*)] ...) ,(do-expr body)))]
(do-expr body))]
[(letrec* ([,x* ,e*] ...) ,body) [(letrec* ([,x* ,e*] ...) ,body)
(bump!) (bump!)
(safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*)) (safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*))
(let ([do-expr (ids->do-expr (append x* ids))]) (let ([do-expr (ids->do-expr (append x* ids))])
(for-each do-expr e*) `(letrec* ([,x* ,(map do-expr e*)] ...) ,(do-expr body)))]
(do-expr body))] [(record-type ,rtd ,[do-expr : e]) `(record-type ,rtd ,e)]
[(record-type ,rtd ,[do-expr : e]) (void)] [(record-cd ,rcd ,rtd-expr ,[do-expr : e]) `(record-cd ,rcd ,rtd-expr ,e)]
[(record-cd ,rcd ,rtd-expr ,[do-expr : e]) (void)] [(record-ref ,rtd ,type ,index ,[do-expr : e])
[(record-ref ,rtd ,type ,index ,[do-expr : e]) (bump!)] (bump!)
[(record-set! ,rtd ,type ,index ,[do-expr : e1] ,[do-expr : e2]) (bump!)] `(record-ref ,rtd ,type ,index ,e)]
[(record ,rtd ,[do-expr : rtd-expr] ,[do-expr : e*] ...) (bump!)] [(record-set! ,rtd ,type ,index ,[do-expr : e1] ,[do-expr : e2])
[(immutable-list (,[e*] ...) ,[e]) (void)] (bump!)
[(pariah) (void)] `(record-set! ,rtd ,type ,index ,e1 ,e2)]
[(profile ,src) (void)] [(record ,rtd ,[do-expr : rtd-expr] ,[do-expr : e*] ...)
(bump!)
`(record ,rtd ,rtd-expr ,e* ...)]
[(immutable-list (,[e*] ...) ,[e])
`(immutable-list (,e* ...) ,e)]
[(pariah) e]
[(profile ,src) e]
[else (exit #f)])))) [else (exit #f)]))))
(nanopass-case (Lsrc CaseLambdaClause) clause (nanopass-case (Lsrc CaseLambdaClause) clause
[(clause (,x* ...) ,interface ,body) [(clause (,x* ...) ,interface ,body)
(safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*)) (safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*))
((ids->do-expr (append x* ids)) body)])))) (with-output-language (Lsrc CaseLambdaClause)
((ids->do-clause '()) clause) `(clause (,x* ...) ,interface ,((ids->do-expr (append x* ids)) body)))]))))
#t)))) ((ids->do-clause '()) clause)))))
(module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued? (module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued?
single-valued? single-valued single-valued-join single-valued-reduce? single-valued? single-valued single-valued-join single-valued-reduce?
@ -1042,7 +1065,7 @@
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure1? e*) (pure? body)))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure1? e*) (pure? body)))]
[(immutable-list (,e* ...) ,e) (memoize (and (andmap pure1? e*) (pure? e)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap pure1? e*) (pure? e)))]
[(profile ,src) #t] [(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (pure? e))] [(cte-optimization-loc ,box ,e ,exts) (memoize (pure? e))]
[(moi) #t] [(moi) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure1? e))] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure1? e))]
[(pariah) #t] [(pariah) #t]
@ -1106,7 +1129,7 @@
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory1? e*) (ivory? body)))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory1? e*) (ivory? body)))]
[(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory1? e*) (ivory? e)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory1? e*) (ivory? e)))]
[(profile ,src) #t] [(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (ivory? e))] [(cte-optimization-loc ,box ,e ,exts) (memoize (ivory? e))]
[(moi) #t] [(moi) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory1? e))] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory1? e))]
[(pariah) #t] [(pariah) #t]
@ -1156,7 +1179,7 @@
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple1? rtd-expr) (andmap simple1? e*)))] [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple1? rtd-expr) (andmap simple1? e*)))]
[(pariah) #f] [(pariah) #f]
[(profile ,src) #f] [(profile ,src) #f]
[(cte-optimization-loc ,box ,e) (memoize (simple? e))] [(cte-optimization-loc ,box ,e ,exts) (memoize (simple? e))]
[(moi) #t] [(moi) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple1? e))] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple1? e))]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
@ -1207,7 +1230,7 @@
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile1? rtd-expr) (andmap simple/profile1? e*)))] [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile1? rtd-expr) (andmap simple/profile1? e*)))]
[(pariah) #t] [(pariah) #t]
[(profile ,src) #t] [(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (simple/profile? e))] [(cte-optimization-loc ,box ,e ,exts) (memoize (simple/profile? e))]
[(moi) #t] [(moi) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile1? e))] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile1? e))]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
@ -1270,7 +1293,7 @@
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(record ,rtd ,rtd-expr ,e* ...) #f] [(record ,rtd ,rtd-expr ,e* ...) #f]
[(immutable-list (,e* ...) ,e) #f] [(immutable-list (,e* ...) ,e) #f]
[(cte-optimization-loc ,box ,e) (memoize (boolean-valued? e))] [(cte-optimization-loc ,box ,e ,exts) (memoize (boolean-valued? e))]
[(profile ,src) #f] [(profile ,src) #f]
[(set! ,maybe-src ,x ,e) #f] [(set! ,maybe-src ,x ,e) #f]
[(moi) #f] [(moi) #f]
@ -1341,7 +1364,7 @@
[(record ,rtd ,rtd-expr ,e* ...) #t] [(record ,rtd ,rtd-expr ,e* ...) #t]
[(pariah) #t] [(pariah) #t]
[(profile ,src) #t] [(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (single-valued e))] [(cte-optimization-loc ,box ,e ,exts) (memoize (single-valued e))]
[(moi) #t] [(moi) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
@ -1807,7 +1830,9 @@
(context-case ctxt (context-case ctxt
[(test) true-rec] [(test) true-rec]
[(app) [(app)
(with-values (find-lambda-clause rhs ctxt) (with-values (if (preinfo-call-can-inline? (app-preinfo ctxt))
(find-lambda-clause rhs ctxt)
(values))
(case-lambda (case-lambda
[(ids body) [(ids body)
(let ([limit (if (passive-scorer? sc) (let ([limit (if (passive-scorer? sc)
@ -2906,6 +2931,7 @@
[(quote ,d) [(quote ,d)
(cond (cond
[(and (symbol? d) (okay-to-handle?) [(and (symbol? d) (okay-to-handle?)
(preinfo-call-can-inline? (app-preinfo ctxt)) ; $top-level-value may be marked by previous inline
(assq ($target-machine) ($cte-optimization-info d))) => (assq ($target-machine) ($cte-optimization-info d))) =>
(lambda (as) (lambda (as)
(let ([opt (cdr as)]) (let ([opt (cdr as)])
@ -2922,8 +2948,24 @@
; reprocess to complete inlining done in the same cp0 pass and, more ; reprocess to complete inlining done in the same cp0 pass and, more
; importantly, to rewrite any prelexes so multiple call sites don't ; importantly, to rewrite any prelexes so multiple call sites don't
; result in multiple bindings for the same prelexes ; result in multiple bindings for the same prelexes
[(app) (residualize-seq '() (list x) ctxt) [(app)
(and
;; Check that enclosing call allows inlining, which is a
;; separate specification from the nested `$top-level-value` call:
(preinfo-call-can-inline? (app-preinfo (app-ctxt ctxt)))
;; The `case-lambda` form for inlining may have fewer cases
;; than the actual binding, so only try to inline if there's
;; a matching clause
(let ([n (length (app-opnds (app-ctxt ctxt)))])
(cond
[(ormap (lambda (cl)
(nanopass-case (Lsrc CaseLambdaClause) cl
[(clause (,x* ...) ,interface ,body)
(= n interface)]))
cl*)
(residualize-seq '() (list x) ctxt)
(cp0 opt (app-ctxt ctxt) empty-env sc wd (app-name ctxt) moi)] (cp0 opt (app-ctxt ctxt) empty-env sc wd (app-name ctxt) moi)]
[else #f])))]
[else #f])] [else #f])]
[else #f])))] [else #f])))]
[else #f])] [else #f])]
@ -4874,7 +4916,17 @@
[(call ,preinfo ,pr ,e ,e* ...) [(call ,preinfo ,pr ,e ,e* ...)
(guard (eq? (primref-name pr) '$app)) (guard (eq? (primref-name pr) '$app))
(let ([preinfo (make-preinfo-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (let ([preinfo (make-preinfo-call (preinfo-src preinfo) (preinfo-sexpr preinfo)
(not (all-set? (prim-mask unsafe) (primref-flags pr))))]) (if (all-set? (prim-mask unsafe) (primref-flags pr))
(preinfo-call-mask unchecked)
(preinfo-call-mask)))])
(cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))]
[(call ,preinfo ,pr ,e ,e* ...)
(guard (eq? (primref-name pr) '$app/no-inline))
(let ([preinfo (make-preinfo-call (preinfo-src preinfo) (preinfo-sexpr preinfo)
(set-flags (if (all-set? (prim-mask unsafe) (primref-flags pr))
(preinfo-call-mask unchecked)
(preinfo-call-mask))
(preinfo-call-mask no-inline)))])
(cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))] (cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))]
[(call ,preinfo ,e ,e* ...) [(call ,preinfo ,e ,e* ...)
(let () (let ()
@ -5076,7 +5128,7 @@
`(immutable-list (,e* ...) ,e)] `(immutable-list (,e* ...) ,e)]
[(moi) (if moi `(quote ,moi) ir)] [(moi) (if moi `(quote ,moi) ir)]
[(pariah) ir] [(pariah) ir]
[(cte-optimization-loc ,box ,[cp0 : e ctxt env sc wd name moi -> e]) [(cte-optimization-loc ,box ,[cp0 : e ctxt env sc wd name moi -> e] ,exts)
(when (enable-cross-library-optimization) (when (enable-cross-library-optimization)
(let () (let ()
(define update-box! (define update-box!
@ -5093,11 +5145,21 @@
(let ([rhs (result-exp (operand-value (prelex-operand x)))]) (let ([rhs (result-exp (operand-value (prelex-operand x)))])
(nanopass-case (Lsrc Expr) rhs (nanopass-case (Lsrc Expr) rhs
[(case-lambda ,preinfo ,cl* ...) [(case-lambda ,preinfo ,cl* ...)
(when (andmap externally-inlinable? cl*) ;; Function registered for inlining may report fewer clauses
(update-box! box rhs))] ;; than supported by the original, since only inlinable clauses
;; are kept
(let ([cl* (fold-right (lambda (cl cl*)
(let ([cl (externally-inlinable cl exts)])
(if cl
(cons cl cl*)
cl*)))
'()
cl*)])
(when (pair? cl*)
(update-box! box `(case-lambda ,preinfo ,cl* ...))))]
[else #f])))] [else #f])))]
[else (void)]))) [else (void)])))
`(cte-optimization-loc ,box ,e)] `(cte-optimization-loc ,box ,e ,exts)]
[(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)]
[(profile ,src) ir] [(profile ,src) ir]
[else ($oops who "unrecognized record ~s" ir)]) [else ($oops who "unrecognized record ~s" ir)])

2
s/cpcheck.ss
View File

@ -208,7 +208,7 @@
,(map (lambda (arg) (cond [(eqv? arg 0) `(quote 0)] [else arg])) ,(map (lambda (arg) (cond [(eqv? arg 0) `(quote 0)] [else arg]))
(make-record-call-args fld* (rtd-size rtd) e*)) (make-record-call-args fld* (rtd-size rtd) e*))
...)))))))] ...)))))))]
[(cte-optimization-loc ,box ,[e #f -> e]) e] [(cte-optimization-loc ,box ,[e #f -> e] ,exts) e]
[(immutable-list (,e* ...) ,[e]) e] [(immutable-list (,e* ...) ,[e]) e]
[(moi) ir] [(moi) ir]
[(pariah) ir] [(pariah) ir]

10
s/cpcommonize.ss
View File

@ -113,8 +113,8 @@
(values `(record-set! ,rtd ,type ,index ,e1 ,e2) (fx+ size1 size2 1))] (values `(record-set! ,rtd ,type ,index ,e1 ,e2) (fx+ size1 size2 1))]
[(record ,rtd ,[rtd-expr size] ,[e* size*] ...) [(record ,rtd ,[rtd-expr size] ,[e* size*] ...)
(values `(record ,rtd ,rtd-expr ,e* ...) (apply fx+ size size*))] (values `(record ,rtd ,rtd-expr ,e* ...) (apply fx+ size size*))]
[(cte-optimization-loc ,box ,[e size]) [(cte-optimization-loc ,box ,[e size] ,exts)
(values `(cte-optimization-loc ,box ,e) size)] (values `(cte-optimization-loc ,box ,e ,exts) size)]
[(immutable-list (,[e* size*] ...) ,[e size]) [(immutable-list (,[e* size*] ...) ,[e size])
(values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))] (values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))]
[(quote ,d) (values `(quote ,d) 1)] [(quote ,d) (values `(quote ,d) 1)]
@ -398,11 +398,11 @@
(same-type? result-type1 result-type2) (same-type? result-type1 result-type2)
`(fcallable (,conv1* ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))] `(fcallable (,conv1* ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])] [else #f])]
[(cte-optimization-loc ,box1 ,e1) [(cte-optimization-loc ,box1 ,e1 ,exts1)
(nanopass-case (Lcommonize1 Expr) e2 (nanopass-case (Lcommonize1 Expr) e2
[(cte-optimization-loc ,box2 ,e2) [(cte-optimization-loc ,box2 ,e2 ,exts2)
(and (eq? box1 box2) (and (eq? box1 box2)
`(cte-optimization-loc ,box1 ,(f e1 e2)))] `(cte-optimization-loc ,box1 ,(f e1 e2) ,exts1))]
[else #f])] [else #f])]
[else (sorry! who "unhandled record ~s" e1)])]) [else (sorry! who "unhandled record ~s" e1)])])
(return (iffalse #f (parameterize ([print-level 3] [print-length 5]) (printf "unify failed for ~s and ~s (call-position ~s)\n" e1 e2 call-position?))) '()))])) (return (iffalse #f (parameterize ([print-level 3] [print-length 5]) (printf "unify failed for ~s and ~s (call-position ~s)\n" e1 e2 call-position?))) '()))]))

4
s/cpletrec.ss
View File

@ -382,8 +382,8 @@ Handling letrec and letrec*
[,pr (values pr #t)] [,pr (values pr #t)]
[(moi) (values ir #t)] [(moi) (values ir #t)]
[(pariah) (values ir #t)] [(pariah) (values ir #t)]
[(cte-optimization-loc ,box ,[e pure?]) [(cte-optimization-loc ,box ,[e pure?] ,exts)
(values `(cte-optimization-loc ,box ,e) pure?)] (values `(cte-optimization-loc ,box ,e ,exts) pure?)]
[(profile ,src) (values ir #f)] [(profile ,src) (values ir #f)]
[else (sorry! who "unhandled record ~s" ir)]) [else (sorry! who "unhandled record ~s" ir)])
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()

11
s/cprep.ss
View File

@ -157,13 +157,20 @@
[(call ,preinfo ,e ,e* ...) [(call ,preinfo ,e ,e* ...)
(cache-sexpr preinfo (cache-sexpr preinfo
(lambda () (lambda ()
(nanopass-case (Lsrc Expr) e
[,pr `(,(uncprep e) ,@(map uncprep e*))]
[else
(let ([a `(,(uncprep e) ,@(map uncprep e*))]) (let ([a `(,(uncprep e) ,@(map uncprep e*))])
(if (or (preinfo-call-check? preinfo) (if (or (preinfo-call-check? preinfo)
;; Reporting `#3%$app` is redundant for unsafe mode. ;; Reporting `#3%$app` is redundant for unsafe mode.
;; Note that we're losing explicit `#2%$app`s. ;; Note that we're losing explicit `#2%$app`s.
(>= (optimize-level) 3)) (>= (optimize-level) 3))
(if (preinfo-call-can-inline? preinfo)
a a
(cons '#3%$app a)))))] (cons '$app/no-inline a))
(if (preinfo-call-can-inline? preinfo)
(cons '#3%$app a)
(cons '#3%$app/no-inline a))))])))]
[,pr (let ([sym (primref-name pr)]) [,pr (let ([sym (primref-name pr)])
(if sexpr? (if sexpr?
($sgetprop sym '*unprefixed* sym) ($sgetprop sym '*unprefixed* sym)
@ -210,7 +217,7 @@
[(moi) ''moi] [(moi) ''moi]
[(pariah) `(pariah (void))] [(pariah) `(pariah (void))]
[(profile ,src) `(void)] [(profile ,src) `(void)]
[(cte-optimization-loc ,box ,[e]) e] [(cte-optimization-loc ,box ,[e] ,exts) e]
; for debugging: ; for debugging:
[(cpvalid-defer ,[e]) `(cpvalid-defer ,e)] [(cpvalid-defer ,[e]) `(cpvalid-defer ,e)]
[else ($oops who "unexpected record ~s" x)]))) [else ($oops who "unexpected record ~s" x)])))

4
s/cptypes.ss
View File

@ -1059,8 +1059,8 @@ Notes:
ret types #f #f)] ret types #f #f)]
[(moi) (values ir #f types #f #f)] [(moi) (values ir #f types #f #f)]
[(pariah) (values ir void-rec types #f #f)] [(pariah) (values ir void-rec types #f #f)]
[(cte-optimization-loc ,box ,[e 'value types -> e ret types t-types f-types]) [(cte-optimization-loc ,box ,[e 'value types -> e ret types t-types f-types] ,exts)
(values `(cte-optimization-loc ,box ,e) (values `(cte-optimization-loc ,box ,e ,exts)
ret types #f #f)] ret types #f #f)]
[(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)]
[(profile ,src) (values ir #f types #f #f)] [(profile ,src) (values ir #f types #f #f)]

8
s/cpvalid.ss
View File

@ -339,8 +339,8 @@
(defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))] (defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable (,conv* ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))] (defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[undefer : e dl?]) [(cte-optimization-loc ,box ,[undefer : e dl?] ,exts)
(defer-or-not dl? `(cte-optimization-loc ,box ,e))] (defer-or-not dl? `(cte-optimization-loc ,box ,e ,exts))]
[(pariah) (values x #f)] [(pariah) (values x #f)]
[(profile ,src) (values x #f)] [(profile ,src) (values x #f)]
[(moi) (values x #f)] [(moi) (values x #f)]
@ -558,8 +558,8 @@
(defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))] (defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable (,conv* ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))] (defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[cpvalid : e dl?]) [(cte-optimization-loc ,box ,[cpvalid : e dl?] ,exts)
(defer-or-not dl? `(cte-optimization-loc ,box ,e))] (defer-or-not dl? `(cte-optimization-loc ,box ,e ,exts))]
[(pariah) (values x #f)] [(pariah) (values x #f)]
[(profile ,src) (values x #f)] [(profile ,src) (values x #f)]
[(moi) (values x #f)] [(moi) (values x #f)]

2
s/primdata.ss
View File

@ -1782,6 +1782,7 @@
($address->object [flags single-valued]) ($address->object [flags single-valued])
($allocate-thread-parameter [feature pthreads] [flags single-valued alloc]) ($allocate-thread-parameter [feature pthreads] [flags single-valued alloc])
($app [flags]) ($app [flags])
($app/no-inline [flags])
($apply [flags]) ($apply [flags])
($assembly-output [flags single-valued]) ($assembly-output [flags single-valued])
($as-time-goes-by [flags]) ($as-time-goes-by [flags])
@ -1791,6 +1792,7 @@
($build-install-library/ct-code [flags single-valued]) ($build-install-library/ct-code [flags single-valued])
($build-install-library/rt-code [flags single-valued]) ($build-install-library/rt-code [flags single-valued])
($build-invoke-program [flags single-valued]) ($build-invoke-program [flags single-valued])
($build-library-exts [flags single-valued])
($byte-copy! [flags single-valued]) ($byte-copy! [flags single-valued])
($bytevector-ref-check? [sig [(sub-uint ptr ptr) -> (boolean)]] [flags pure]) ($bytevector-ref-check? [sig [(sub-uint ptr ptr) -> (boolean)]] [flags pure])
($bytevector-set!-check? [sig [(sub-uint ptr ptr) -> (boolean)]] [flags discard]) ($bytevector-set!-check? [sig [(sub-uint ptr ptr) -> (boolean)]] [flags discard])

4
s/prims.ss
View File

@ -369,6 +369,10 @@
(lambda (f . args) (lambda (f . args)
(#2%apply f args))) (#2%apply f args)))
(define $app/no-inline
(lambda (f . args)
(#2%apply f args)))
(define call-with-values (define call-with-values
(lambda (producer consumer) (lambda (producer consumer)
(unless (procedure? producer) (unless (procedure? producer)

27
s/syntax.ss
View File

@ -550,7 +550,10 @@
(define build-call (define build-call
(lambda (ae e e*) (lambda (ae e e*)
(build-profile ae (build-profile ae
`(call ,(make-preinfo-call (ae->src ae) #f (fx< (optimize-level) 3)) ,e ,e* ...)))) (let ([flags (if (fx< (optimize-level) 3)
(preinfo-call-mask)
(preinfo-call-mask unchecked))])
`(call ,(make-preinfo-call (ae->src ae) #f flags) ,e ,e* ...)))))
(define build-application (define build-application
; used by chi-application. pulls profile form off e if e is a lambda expression ; used by chi-application. pulls profile form off e if e is a lambda expression
@ -593,11 +596,11 @@
(build-profile ae `(set! ,(ae->src ae) ,var ,exp)))) (build-profile ae `(set! ,(ae->src ae) ,var ,exp))))
(define build-cte-optimization-loc (define build-cte-optimization-loc
(lambda (box exp) (lambda (box exp exts)
; box is for cp0 to store optimization info, if it pleases. the box is eq? to ; box is for cp0 to store optimization info, if it pleases. the box is eq? to
; the box on the system property list for the library global label and ; the box on the system property list for the library global label and
; stored in the library/ct-info record for the file. ; stored in the library/ct-info record for the file.
`(cte-optimization-loc ,box ,exp))) `(cte-optimization-loc ,box ,exp ,exts)))
(define build-primitive-reference (define build-primitive-reference
(lambda (ae name) (lambda (ae name)
@ -841,6 +844,7 @@
(define build-library-body (define build-library-body
(lambda (ae labels boxes vars val-exps body-exp) (lambda (ae labels boxes vars val-exps body-exp)
(let ([exts (build-library-exts labels vars)])
(build-letrec* ae vars val-exps (build-letrec* ae vars val-exps
(fold-right (fold-right
(lambda (label box var body) (lambda (label box var body)
@ -848,10 +852,20 @@
`(seq `(seq
,(build-global-assignment no-source label ,(build-global-assignment no-source label
(build-cte-optimization-loc box (build-cte-optimization-loc box
(build-lexical-reference no-source var))) (build-lexical-reference no-source var)
exts))
,body) ,body)
body)) body))
body-exp labels boxes vars)))) body-exp labels boxes vars)))))
(define (build-library-exts labels vars)
(fold-left (lambda (exts label var)
(if label
(cons (cons var label) exts)
exts))
'()
labels
vars))
(define build-lexical-var (define build-lexical-var
(lambda (ae id) (lambda (ae id)
@ -7225,6 +7239,9 @@
(set! $noexpand? (set! $noexpand?
(lambda (x) (lambda (x)
(and (pair? x) (equal? (car x) noexpand)))) (and (pair? x) (equal? (car x) noexpand))))
(set! $build-library-exts build-library-exts)
)) ))
(current-expand sc-expand) (current-expand sc-expand)