diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index 905f2f5898..4d50ed6721 100644 --- a/makefiles/Mf-install.in +++ b/makefiles/Mf-install.in @@ -62,7 +62,7 @@ InstallLZ4Target= # no changes should be needed below this point # ############################################################################### -Version=csv9.5.3.12 +Version=csv9.5.3.13 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/s/base-lang.ss b/s/base-lang.ss index 585b800385..f6682a8e48 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -18,7 +18,7 @@ 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 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-source prelex-operand prelex-operand-set! prelex-uname make-prelex* target-fixnum? target-bignum?) @@ -185,17 +185,23 @@ [(src sexpr libspec name flags) ((pargs->new src sexpr) libspec name flags)])))) (define-record-type preinfo-call - (nongenerative #{preinfo-call e23pkvo5btgapnzomqgegm-7}) + (nongenerative #{preinfo-call e23pkvo5btgapnzomqgegm-8}) (parent preinfo) (sealed #t) - (fields check?) + (fields flags) (protocol (lambda (pargs->new) (case-lambda - [() ((pargs->new) #t)] - [(src) ((pargs->new src) #t)] - [(src sexpr) ((pargs->new src sexpr) #t)] - [(src sexpr check?) ((pargs->new src sexpr) check?)])))) + [() ((pargs->new) (preinfo-call-mask))] + [(src) ((pargs->new src) (preinfo-call-mask))] + [(src sexpr) ((pargs->new src sexpr) (preinfo-call-mask))] + [(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 (define-language Ltype @@ -242,7 +248,8 @@ (convention (conv)) (maybe-string (name)) (symbol (sym type)) - (primref (pr))) + (primref (pr)) + (list (exts))) (Expr (e body rtd-expr) pr (moi) @@ -262,7 +269,7 @@ (record rtd rtd-expr e* ...) (record-ref rtd type index e) (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) (fcallable (conv* ...) e (arg-type* ...) result-type) (profile src) => (profile) diff --git a/s/cmacros.ss b/s/cmacros.ss index c794884b49..7c8807e171 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -328,7 +328,7 @@ [(_ foo e1 e2) e1] ... [(_ bar e1 e2) e2]))))]))) -(define-constant scheme-version #x0905030C) +(define-constant scheme-version #x0905030D) (define-syntax define-machine-types (lambda (x) @@ -1660,7 +1660,12 @@ (boolean-valued #b0010000000) (single-valued-known #b0100000000) (single-valued #b1000000000) -) + ) + +(define-flags preinfo-call-mask + (unchecked #b01) + (no-inline #b10) + ) (define-syntax define-flag-field (lambda (exp) diff --git a/s/compile.ss b/s/compile.ss index 7fbac0b5e9..eaffb64c0e 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -1185,14 +1185,15 @@ (lambda (node) (nanopass-case (Lexpand rtLibrary) (library-node-rtir node) [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) - (fold-right - (lambda (dl db dv body) - (if dl - `(seq ,(build-primcall '$set-top-level-value! `(quote ,dl) - `(cte-optimization-loc ,db (ref #f ,dv))) - ,body) - body)) - (build-void) dl* db* dv*)]))) + (let ([exts ($build-library-exts dl* dv*)]) + (fold-right + (lambda (dl db dv body) + (if dl + `(seq ,(build-primcall '$set-top-level-value! `(quote ,dl) + `(cte-optimization-loc ,db (ref #f ,dv) ,exts)) + ,body) + body)) + (build-void) dl* db* dv*))]))) (define make-patch-env (lambda (cluster*) diff --git a/s/cp0.ss b/s/cp0.ss index 83a1d3a26a..5b9df5bb14 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -878,15 +878,24 @@ ($unbound-object? obj) (record-type-descriptor? obj)))) - (define externally-inlinable? - (lambda (clause) + ;; Returns #f if the clause is not externally inlinable + (define externally-inlinable + (lambda (clause exts) (call/cc - (lambda (exit) + (lambda (exit) (define bump! (let ([size 0]) (lambda () (set! size (fx+ size 1)) (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) (rec do-clause (lambda (clause) @@ -894,58 +903,72 @@ (rec do-expr (lambda (e) (nanopass-case (Lsrc Expr) e - [(quote ,d) (if (okay-to-copy? d) (bump!) (exit #f))] - [(moi) (bump!)] - [,pr (bump!)] - [(ref ,maybe-src ,x) (unless (memq x ids) (exit #f)) (bump!)] - [(seq ,[do-expr : e1] ,[do-expr : e2]) (void)] - [(if ,[do-expr : e1] ,[do-expr : e2] ,[do-expr : e3]) (void)] + [(quote ,d) (if (okay-to-copy? d) (begin (bump!) e) (exit #f))] + [(moi) (bump!) e] + [,pr (bump!) e] + [(ref ,maybe-src ,x) (cond + [(memq x ids) (bump!) e] + [(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) (unless (memq x ids) (exit #f)) (bump!) (do-expr e)] [(call ,preinfo ,e ,e* ...) ; 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 [,pr (eq? (primref-name pr) '$top-level-value)] [else #f]) (= (length e*) 1) - (cp0-constant? gensym? (car e*))) + (cp0-constant? gensym? (car e*)) + (not (expand-omit-library-invocations))) (exit #f)) (bump!) - (do-expr e) - (for-each do-expr e*)] + `(call ,preinfo ,(do-expr e) ,(map do-expr e*) ...)] [(case-lambda ,preinfo ,cl* ...) (bump!) - (for-each (ids->do-clause ids) cl*)] + `(case-lambda ,preinfo ,(map (ids->do-clause ids) cl*) ...)] [(letrec ([,x* ,e*] ...) ,body) (bump!) (safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*)) (let ([do-expr (ids->do-expr (append x* ids))]) - (for-each do-expr e*) - (do-expr body))] + `(letrec ([,x* ,(map do-expr e*)] ...) ,(do-expr body)))] [(letrec* ([,x* ,e*] ...) ,body) (bump!) (safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*)) (let ([do-expr (ids->do-expr (append x* ids))]) - (for-each do-expr e*) - (do-expr body))] - [(record-type ,rtd ,[do-expr : e]) (void)] - [(record-cd ,rcd ,rtd-expr ,[do-expr : e]) (void)] - [(record-ref ,rtd ,type ,index ,[do-expr : e]) (bump!)] - [(record-set! ,rtd ,type ,index ,[do-expr : e1] ,[do-expr : e2]) (bump!)] - [(record ,rtd ,[do-expr : rtd-expr] ,[do-expr : e*] ...) (bump!)] - [(immutable-list (,[e*] ...) ,[e]) (void)] - [(pariah) (void)] - [(profile ,src) (void)] + `(letrec* ([,x* ,(map do-expr e*)] ...) ,(do-expr body)))] + [(record-type ,rtd ,[do-expr : e]) `(record-type ,rtd ,e)] + [(record-cd ,rcd ,rtd-expr ,[do-expr : e]) `(record-cd ,rcd ,rtd-expr ,e)] + [(record-ref ,rtd ,type ,index ,[do-expr : e]) + (bump!) + `(record-ref ,rtd ,type ,index ,e)] + [(record-set! ,rtd ,type ,index ,[do-expr : e1] ,[do-expr : e2]) + (bump!) + `(record-set! ,rtd ,type ,index ,e1 ,e2)] + [(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)])))) (nanopass-case (Lsrc CaseLambdaClause) clause [(clause (,x* ...) ,interface ,body) (safe-assert (andmap (lambda (x) (not (prelex-operand x))) x*)) - ((ids->do-expr (append x* ids)) body)])))) - ((ids->do-clause '()) clause) - #t)))) + (with-output-language (Lsrc CaseLambdaClause) + `(clause (,x* ...) ,interface ,((ids->do-expr (append x* ids)) body)))])))) + ((ids->do-clause '()) clause))))) (module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued? 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)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap pure1? e*) (pure? e)))] [(profile ,src) #t] - [(cte-optimization-loc ,box ,e) (memoize (pure? e))] + [(cte-optimization-loc ,box ,e ,exts) (memoize (pure? e))] [(moi) #t] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure1? e))] [(pariah) #t] @@ -1106,7 +1129,7 @@ [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory1? e*) (ivory? body)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory1? e*) (ivory? e)))] [(profile ,src) #t] - [(cte-optimization-loc ,box ,e) (memoize (ivory? e))] + [(cte-optimization-loc ,box ,e ,exts) (memoize (ivory? e))] [(moi) #t] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory1? e))] [(pariah) #t] @@ -1156,7 +1179,7 @@ [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple1? rtd-expr) (andmap simple1? e*)))] [(pariah) #f] [(profile ,src) #f] - [(cte-optimization-loc ,box ,e) (memoize (simple? e))] + [(cte-optimization-loc ,box ,e ,exts) (memoize (simple? e))] [(moi) #t] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple1? 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*)))] [(pariah) #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] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile1? e))] [else ($oops who "unrecognized record ~s" e)])))) @@ -1270,7 +1293,7 @@ [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(record ,rtd ,rtd-expr ,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] [(set! ,maybe-src ,x ,e) #f] [(moi) #f] @@ -1341,7 +1364,7 @@ [(record ,rtd ,rtd-expr ,e* ...) #t] [(pariah) #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] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t] [else ($oops who "unrecognized record ~s" e)])))) @@ -1807,7 +1830,9 @@ (context-case ctxt [(test) true-rec] [(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 [(ids body) (let ([limit (if (passive-scorer? sc) @@ -2906,6 +2931,7 @@ [(quote ,d) (cond [(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))) => (lambda (as) (let ([opt (cdr as)]) @@ -2922,8 +2948,24 @@ ; reprocess to complete inlining done in the same cp0 pass and, more ; importantly, to rewrite any prelexes so multiple call sites don't ; result in multiple bindings for the same prelexes - [(app) (residualize-seq '() (list x) ctxt) - (cp0 opt (app-ctxt ctxt) empty-env sc wd (app-name ctxt) moi)] + [(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)] + [else #f])))] [else #f])] [else #f])))] [else #f])] @@ -4874,7 +4916,17 @@ [(call ,preinfo ,pr ,e ,e* ...) (guard (eq? (primref-name pr) '$app)) (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))] [(call ,preinfo ,e ,e* ...) (let () @@ -5076,7 +5128,7 @@ `(immutable-list (,e* ...) ,e)] [(moi) (if moi `(quote ,moi) 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) (let () (define update-box! @@ -5093,11 +5145,21 @@ (let ([rhs (result-exp (operand-value (prelex-operand x)))]) (nanopass-case (Lsrc Expr) rhs [(case-lambda ,preinfo ,cl* ...) - (when (andmap externally-inlinable? cl*) - (update-box! box rhs))] + ;; Function registered for inlining may report fewer clauses + ;; 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 (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)] [(profile ,src) ir] [else ($oops who "unrecognized record ~s" ir)]) diff --git a/s/cpcheck.ss b/s/cpcheck.ss index 130e920086..407b244f42 100644 --- a/s/cpcheck.ss +++ b/s/cpcheck.ss @@ -208,7 +208,7 @@ ,(map (lambda (arg) (cond [(eqv? arg 0) `(quote 0)] [else arg])) (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] [(moi) ir] [(pariah) ir] diff --git a/s/cpcommonize.ss b/s/cpcommonize.ss index 3661020065..dd29d5944f 100644 --- a/s/cpcommonize.ss +++ b/s/cpcommonize.ss @@ -113,8 +113,8 @@ (values `(record-set! ,rtd ,type ,index ,e1 ,e2) (fx+ size1 size2 1))] [(record ,rtd ,[rtd-expr size] ,[e* size*] ...) (values `(record ,rtd ,rtd-expr ,e* ...) (apply fx+ size size*))] - [(cte-optimization-loc ,box ,[e size]) - (values `(cte-optimization-loc ,box ,e) size)] + [(cte-optimization-loc ,box ,[e size] ,exts) + (values `(cte-optimization-loc ,box ,e ,exts) size)] [(immutable-list (,[e* size*] ...) ,[e size]) (values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))] [(quote ,d) (values `(quote ,d) 1)] @@ -398,11 +398,11 @@ (same-type? result-type1 result-type2) `(fcallable (,conv1* ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))] [else #f])] - [(cte-optimization-loc ,box1 ,e1) + [(cte-optimization-loc ,box1 ,e1 ,exts1) (nanopass-case (Lcommonize1 Expr) e2 - [(cte-optimization-loc ,box2 ,e2) + [(cte-optimization-loc ,box2 ,e2 ,exts2) (and (eq? box1 box2) - `(cte-optimization-loc ,box1 ,(f e1 e2)))] + `(cte-optimization-loc ,box1 ,(f e1 e2) ,exts1))] [else #f])] [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?))) '()))])) diff --git a/s/cpletrec.ss b/s/cpletrec.ss index b158e48355..ad9b2fcdf1 100644 --- a/s/cpletrec.ss +++ b/s/cpletrec.ss @@ -382,8 +382,8 @@ Handling letrec and letrec* [,pr (values pr #t)] [(moi) (values ir #t)] [(pariah) (values ir #t)] - [(cte-optimization-loc ,box ,[e pure?]) - (values `(cte-optimization-loc ,box ,e) pure?)] + [(cte-optimization-loc ,box ,[e pure?] ,exts) + (values `(cte-optimization-loc ,box ,e ,exts) pure?)] [(profile ,src) (values ir #f)] [else (sorry! who "unhandled record ~s" ir)]) (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () diff --git a/s/cprep.ss b/s/cprep.ss index a3eeeda806..63f15aea3f 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -157,13 +157,20 @@ [(call ,preinfo ,e ,e* ...) (cache-sexpr preinfo (lambda () - (let ([a `(,(uncprep e) ,@(map uncprep e*))]) - (if (or (preinfo-call-check? preinfo) - ;; Reporting `#3%$app` is redundant for unsafe mode. - ;; Note that we're losing explicit `#2%$app`s. - (>= (optimize-level) 3)) - a - (cons '#3%$app a)))))] + (nanopass-case (Lsrc Expr) e + [,pr `(,(uncprep e) ,@(map uncprep e*))] + [else + (let ([a `(,(uncprep e) ,@(map uncprep e*))]) + (if (or (preinfo-call-check? preinfo) + ;; Reporting `#3%$app` is redundant for unsafe mode. + ;; Note that we're losing explicit `#2%$app`s. + (>= (optimize-level) 3)) + (if (preinfo-call-can-inline? preinfo) + 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)]) (if sexpr? ($sgetprop sym '*unprefixed* sym) @@ -210,7 +217,7 @@ [(moi) ''moi] [(pariah) `(pariah (void))] [(profile ,src) `(void)] - [(cte-optimization-loc ,box ,[e]) e] + [(cte-optimization-loc ,box ,[e] ,exts) e] ; for debugging: [(cpvalid-defer ,[e]) `(cpvalid-defer ,e)] [else ($oops who "unexpected record ~s" x)]))) diff --git a/s/cptypes.ss b/s/cptypes.ss index 0ee0f4a7e3..d34a72a93e 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -1059,8 +1059,8 @@ Notes: ret types #f #f)] [(moi) (values ir #f 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]) - (values `(cte-optimization-loc ,box ,e) + [(cte-optimization-loc ,box ,[e 'value types -> e ret types t-types f-types] ,exts) + (values `(cte-optimization-loc ,box ,e ,exts) ret types #f #f)] [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(profile ,src) (values ir #f types #f #f)] diff --git a/s/cpvalid.ss b/s/cpvalid.ss index c3dcdf60d0..35734dca0d 100644 --- a/s/cpvalid.ss +++ b/s/cpvalid.ss @@ -339,8 +339,8 @@ (defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))] [(fcallable (,conv* ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type) (defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))] - [(cte-optimization-loc ,box ,[undefer : e dl?]) - (defer-or-not dl? `(cte-optimization-loc ,box ,e))] + [(cte-optimization-loc ,box ,[undefer : e dl?] ,exts) + (defer-or-not dl? `(cte-optimization-loc ,box ,e ,exts))] [(pariah) (values x #f)] [(profile ,src) (values x #f)] [(moi) (values x #f)] @@ -558,8 +558,8 @@ (defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))] [(fcallable (,conv* ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type) (defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))] - [(cte-optimization-loc ,box ,[cpvalid : e dl?]) - (defer-or-not dl? `(cte-optimization-loc ,box ,e))] + [(cte-optimization-loc ,box ,[cpvalid : e dl?] ,exts) + (defer-or-not dl? `(cte-optimization-loc ,box ,e ,exts))] [(pariah) (values x #f)] [(profile ,src) (values x #f)] [(moi) (values x #f)] diff --git a/s/primdata.ss b/s/primdata.ss index eeb22ee0e3..da1539ced3 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1782,6 +1782,7 @@ ($address->object [flags single-valued]) ($allocate-thread-parameter [feature pthreads] [flags single-valued alloc]) ($app [flags]) + ($app/no-inline [flags]) ($apply [flags]) ($assembly-output [flags single-valued]) ($as-time-goes-by [flags]) @@ -1791,6 +1792,7 @@ ($build-install-library/ct-code [flags single-valued]) ($build-install-library/rt-code [flags single-valued]) ($build-invoke-program [flags single-valued]) + ($build-library-exts [flags single-valued]) ($byte-copy! [flags single-valued]) ($bytevector-ref-check? [sig [(sub-uint ptr ptr) -> (boolean)]] [flags pure]) ($bytevector-set!-check? [sig [(sub-uint ptr ptr) -> (boolean)]] [flags discard]) diff --git a/s/prims.ss b/s/prims.ss index f70ec6e7a0..82c2f55fda 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -369,6 +369,10 @@ (lambda (f . args) (#2%apply f args))) +(define $app/no-inline + (lambda (f . args) + (#2%apply f args))) + (define call-with-values (lambda (producer consumer) (unless (procedure? producer) diff --git a/s/syntax.ss b/s/syntax.ss index bc7251a1fc..088fc2e948 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -550,7 +550,10 @@ (define build-call (lambda (ae e e*) (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 ; 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)))) (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 ; the box on the system property list for the library global label and ; 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 (lambda (ae name) @@ -841,17 +844,28 @@ (define build-library-body (lambda (ae labels boxes vars val-exps body-exp) - (build-letrec* ae vars val-exps - (fold-right - (lambda (label box var body) - (if label - `(seq - ,(build-global-assignment no-source label - (build-cte-optimization-loc box - (build-lexical-reference no-source var))) - ,body) - body)) - body-exp labels boxes vars)))) + (let ([exts (build-library-exts labels vars)]) + (build-letrec* ae vars val-exps + (fold-right + (lambda (label box var body) + (if label + `(seq + ,(build-global-assignment no-source label + (build-cte-optimization-loc box + (build-lexical-reference no-source var) + exts)) + ,body) + body)) + 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 (lambda (ae id) @@ -7225,6 +7239,9 @@ (set! $noexpand? (lambda (x) (and (pair? x) (equal? (car x) noexpand)))) + + +(set! $build-library-exts build-library-exts) )) (current-expand sc-expand)