From 97d982580122fe9e961435cd665033fbc25618ae Mon Sep 17 00:00:00 2001 From: yjqww6 <343519265@qq.com> Date: Sun, 20 Dec 2020 23:00:52 +0800 Subject: [PATCH] ChezScheme: Add a pass to lift well-known closures --- racket/src/ChezScheme/rktboot/constant.rkt | 3 +- racket/src/ChezScheme/rktboot/scheme-lang.rkt | 10 +- racket/src/ChezScheme/s/cmacros.ss | 15 +- racket/src/ChezScheme/s/compile.ss | 5 +- racket/src/ChezScheme/s/cpnanopass.ss | 368 +++++++++++++++++- racket/src/ChezScheme/s/cprep.ss | 8 +- racket/src/ChezScheme/s/front.ss | 1 + racket/src/ChezScheme/s/primdata.ss | 2 + racket/src/ChezScheme/s/syntax.ss | 19 +- 9 files changed, 414 insertions(+), 17 deletions(-) diff --git a/racket/src/ChezScheme/rktboot/constant.rkt b/racket/src/ChezScheme/rktboot/constant.rkt index 6d3edcc4af..45e7b183ee 100644 --- a/racket/src/ChezScheme/rktboot/constant.rkt +++ b/racket/src/ChezScheme/rktboot/constant.rkt @@ -86,7 +86,8 @@ prelex-was-flags-offset prelex-sticky-mask prelex-is-mask - scheme-version) + scheme-version + code-flag-lift-barrier) (provide record-ptr-offset) (define record-ptr-offset 1) diff --git a/racket/src/ChezScheme/rktboot/scheme-lang.rkt b/racket/src/ChezScheme/rktboot/scheme-lang.rkt index e52789c766..17b34d5106 100644 --- a/racket/src/ChezScheme/rktboot/scheme-lang.rkt +++ b/racket/src/ChezScheme/rktboot/scheme-lang.rkt @@ -104,6 +104,7 @@ $compile-profile compile-profile $optimize-closures + $lift-closures $profile-block-data? run-cp0 generate-interrupt-trap @@ -332,7 +333,8 @@ priminfo-libraries $c-bufsiz $foreign-procedure - make-guardian) + make-guardian + $lambda/lift-barrier) (module+ callback (provide set-current-expand-set-callback!)) @@ -703,6 +705,7 @@ [(prelex-was-flags-offset) prelex-was-flags-offset] [(prelex-sticky-mask) prelex-sticky-mask] [(prelex-is-mask) prelex-is-mask] + [(code-flag-lift-barrier) code-flag-lift-barrier] [else (error 'constant "unknown: ~s" #'id)])])) (define $target-machine (make-parameter (string->symbol target-machine))) @@ -932,6 +935,7 @@ (define $compile-profile (make-parameter #f)) (define compile-profile $compile-profile) (define $optimize-closures (make-parameter #t)) +(define $lift-closures (make-parameter #t)) (define $profile-block-data? (make-parameter #f)) (define run-cp0 (make-parameter error)) (define generate-interrupt-trap (make-parameter #t)) @@ -1287,3 +1291,7 @@ [() #f] [(v) (void)] [(v rep) (void)])) + +(define-syntax $lambda/lift-barrier + (syntax-rules () + [(_ fmls body ...) (lambda fmls body ...)])) diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index 82a3d1e866..5f6945d726 100644 --- a/racket/src/ChezScheme/s/cmacros.ss +++ b/racket/src/ChezScheme/s/cmacros.ss @@ -869,13 +869,14 @@ ;; Flags that matter to the GC must apply only to static-generation ;; objects, and they must not overlap with `forward-marker` -(define-constant code-flag-system #b0000001) -(define-constant code-flag-continuation #b0000010) -(define-constant code-flag-template #b0000100) -(define-constant code-flag-guardian #b0001000) -(define-constant code-flag-mutable-closure #b0010000) -(define-constant code-flag-arity-in-closure #b0100000) -(define-constant code-flag-single-valued #b1000000) +(define-constant code-flag-system #b00000001) +(define-constant code-flag-continuation #b00000010) +(define-constant code-flag-template #b00000100) +(define-constant code-flag-guardian #b00001000) +(define-constant code-flag-mutable-closure #b00010000) +(define-constant code-flag-arity-in-closure #b00100000) +(define-constant code-flag-single-valued #b01000000) +(define-constant code-flag-lift-barrier #b10000000) (define-constant fixnum-bits (case (constant ptr-bits) diff --git a/racket/src/ChezScheme/s/compile.ss b/racket/src/ChezScheme/s/compile.ss index 5349d22429..e178ba9f3e 100644 --- a/racket/src/ChezScheme/s/compile.ss +++ b/racket/src/ChezScheme/s/compile.ss @@ -70,7 +70,7 @@ (with-output-language (Lsrc Expr) ($c-make-closure ; pretending main is a library routine to avoid argument-count check - (let ([x `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main)) (clause () 0 ,x))]) + (let ([x `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main) #f (constant code-flag-lift-barrier)) (clause () 0 ,x))]) ($np-compile x #f)))))) (define c-set-code-quad! @@ -559,6 +559,7 @@ [$compile-profile ($compile-profile)] [generate-interrupt-trap (generate-interrupt-trap)] [$optimize-closures ($optimize-closures)] + [$lift-closures ($lift-closures)] [enable-cross-library-optimization (enable-cross-library-optimization)] [generate-covin-files (generate-covin-files)] [enable-arithmetic-left-associative (enable-arithmetic-left-associative)] @@ -646,7 +647,7 @@ (with-output-language (Lsrc Expr) (define (lambda-chunk lsrc) ; pretending main is a library routine to avoid argument-count check - `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main)) + `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main) #f (constant code-flag-lift-barrier)) (clause () 0 ,lsrc))) (define (visit lsrc e* rchunk*) (define (rchunks) (cons (make-visit-chunk (lambda-chunk lsrc)) rchunk*)) diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index 476f2dfec2..6884ffc9c1 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -855,7 +855,7 @@ (define-record-type info-lambda (nongenerative) (parent info) (sealed #t) - (fields src sexpr libspec interface* (mutable dcl*) (mutable flags) (mutable fv*) (mutable name) + (fields src sexpr libspec (mutable interface*) (mutable dcl*) (mutable flags) (mutable fv*) (mutable name) (mutable well-known?) (mutable closure-rep) ctci (mutable pinfo*) seqno) (protocol (lambda (pargs->new) @@ -2099,6 +2099,367 @@ `(closures ([,(map binding-x b*) (,(map binding-x* b*) ...) ,(map binding-le b*)] ...) ,(f (cdr b**)))))))])) + ;;; This pass lifts all internal well-known closures to a intermost lambda body with a lift barrier + (module (np-lift-well-known-closures) + (define-syntax with-level + (syntax-rules () + [(_ [?x* ?level] ?e1 ?e2 ...) + (let ([x* ?x*] [level ?level]) + (for-each (lambda (x) (var-index-set! x level)) x*) + (let ([v (begin ?e1 ?e2 ...)]) + (for-each (lambda (x) (var-index-set! x #f)) x*) + v))])) + + (define-syntax with-lifts + (syntax-rules () + [(_ ?x* ?e1 ?e2 ...) + (with-level [?x* 'lifted] ?e1 ?e2 ...)])) + + ;; defined in or lifted to outer lambda body + (define outer? + (case-lambda + [(target x) + (let ([index (var-index x)]) + (or (eq? index 'lifted) + (fx<= index target)))] + [(target) + (lambda (x) (outer? target x))])) + + (define (lifted? x) + (eq? 'lifted (var-index x))) + + (define-record-type lift-info + (nongenerative) + (sealed #t) + (fields (mutable le**)) + (protocol (lambda (n) (lambda () (n '()))))) + + (define-record-type le-info + (nongenerative) + (sealed #t) + (fields x fv* cle)) + + (define cle-info + (lambda (cle) + (nanopass-case (L6 CaseLambdaExpr) cle + [(case-lambda ,info ,cl* ...) info]))) + + ;; simply a eq-hashtable, but can retrieve the keys deterministically + (define-record-type uvar-set + (nongenerative) + (sealed #t) + (fields ht (mutable ls)) + (protocol + (lambda (n) + (lambda (ls) + (define ht (make-eq-hashtable)) + (for-each (lambda (x) (eq-hashtable-set! ht x #t)) ls) + (n ht ls))))) + + (define uvar-set-has? + (lambda (us x) + (eq-hashtable-contains? (uvar-set-ht us) x))) + + (define uvar-set-add! + (lambda (us x) + (cond + [(null? x) (void)] + [(pair? x) + (for-each (lambda (x) (uvar-set-add! us x)) x)] + [(eq-hashtable-contains? (uvar-set-ht us) x) + (void)] + [else + (eq-hashtable-set! (uvar-set-ht us) x #t) + (uvar-set-ls-set! us (cons x (uvar-set-ls us)))]))) + + (define partition3 + (lambda (proc l1 l2 l3) + (let f ([l1 l1] [l2 l2] [l3 l3]) + (cond + [(null? l1) (values '()'())] + [(proc (car l1) (car l2) (car l3)) + (let-values ([(a b) (f (cdr l1) (cdr l2) (cdr l3))]) + (values (cons (car l1) a) b))] + [else + (let-values ([(a b) (f (cdr l1) (cdr l2) (cdr l3))]) + (values a (cons (car l1) b)))])))) + + (define info-lambda-lift-barrier? + (lambda (info) + (fx= (bitwise-and (info-lambda-flags info) (constant code-flag-lift-barrier)) + (constant code-flag-lift-barrier)))) + + (define-pass np-lift : L6 (ir) -> L6 () + (definitions + (define partition-liftable + (lambda (x* fv** cle*) + (partition3 + (lambda (x fv* cle) + (info-lambda-well-known? (cle-info cle))) + x* fv** cle*))) + + (define find-extra-arg* + (lambda (x arg-info) + (and (lifted? x) + (let ([info (uvar-info-lambda x)]) + (and info + (assq x arg-info)))))) + + (define partition-lift + (lambda (x* x** le* target) + (let f ([x* x*] [x** x**] [le* le*]) + (cond + [(null? x*) (values '() '() '())] + [(lifted? (car x*)) + ;; any free variables other than + ;; procedures lifted or defined in outermost lambda body + ;; are moved to extra arguments + (let*-values ([(new-fv* extra-arg*) (partition (outer? target) (car x**))] + [(rest* lift* extra-arg**) (f (cdr x*) (cdr x**) (cdr le*))]) + (values rest* + (cons (make-le-info (car x*) new-fv* (car le*)) + lift*) + (cons extra-arg* extra-arg**)))] + [else + (let-values ([(rest* lift* extra-arg**) + (f (cdr x*) (cdr x**) (cdr le*))]) + (values (cons (make-le-info (car x*) (car x**) (car le*)) + rest*) + lift* + extra-arg**))])))) + + (define rename + (case-lambda + [(rename-info) + (lambda (x) + (rename rename-info x))] + [(rename-info x) + (cond + [(assq x rename-info) => cdr] + [else x])])) + + (define (make-renamed x) + (make-tmp (uvar-name x))) + + (define-syntax (recur stx) + (syntax-case stx () + [(_ ?f ?e ...) + (identifier? #'?f) + (with-implicit (?f lift-info arg-info rename-info level target) + #'(?f ?e ... lift-info arg-info rename-info level target))])) + + (define rewrite-rest-body + (lambda (le-info lift-info arg-info rename-info level target) + (define new-lift-info (make-lift-info)) + (define le (let ([level (fx+ level 1)] + [lift-info new-lift-info]) + (recur CaseLambdaExpr (le-info-cle le-info)))) + (define lift-x* (map le-info-x (apply append (lift-info-le** new-lift-info)))) + (lift-info-le**-set! lift-info (append (lift-info-le** new-lift-info) (lift-info-le** lift-info))) + ;; add newly lifted procedures as free variables + (values (append lift-x* (le-info-fv* le-info)) le))) + + (define rewrite-rest-le + (lambda (le-info lift-info arg-info rename-info level target) + (define-values (new-fv* new-le) (recur rewrite-rest-body le-info)) + (define us (make-uvar-set new-fv*)) + + ;; also add extra arguments from free lifted procedures as free variables + ;; there is no need to recur since extra arguments of a lifted procedure would not be lifted procedures + (for-each + (lambda (fv) + (cond + [(find-extra-arg* fv arg-info) + => + (lambda (xe*) + (uvar-set-add! us (cdr xe*)))] + [else (void)])) + new-fv*) + + (make-le-info (le-info-x le-info) + (map (rename rename-info) (uvar-set-ls us)) + new-le))) + + (define union-extra-arg* + (lambda (le-info* arg-info extra-arg**) + (define us (make-uvar-set '())) + ;; simply computes a union since lambdas are strongly-connected after np-identify-scc + (for-each + (lambda (le-info extra-arg*) + (uvar-set-add! us extra-arg*) + (for-each + (lambda (fv) + (cond + [(find-extra-arg* fv arg-info) + => + (lambda (x+e*) + (uvar-set-add! us (cdr x+e*)))] + [else (void)])) + (le-info-fv* le-info))) + le-info* extra-arg**) + + ;;if rules in filter-liftable are changed, lambdas passed as extra arguments would no longer be well-known + (for-each + (lambda (x) + (let ([info (uvar-info-lambda x)]) + (and info + (when (info-lambda-well-known? info) + (info-lambda-well-known?-set! info #f))))) + (uvar-set-ls us)) + + (uvar-set-ls us))) + + (define rewrite-lifted-le + (lambda (le-info extra-arg* lift-info arg-info rename-info level target) + (define-values (new-le lift-x*) + (recur LiftedCaseLambdaExpr (le-info-cle le-info) extra-arg*)) + (nanopass-case (L6 CaseLambdaExpr) new-le + [(case-lambda ,info (clause (,x** ...) ,mcp* ,interface* ,body*) ...) + (let* () + (info-lambda-interface*-set! info interface*) + (make-le-info (le-info-x le-info) + ;; add newly lifted procedures as free variables + (append lift-x* (map (rename rename-info) (le-info-fv* le-info))) + new-le))]))) + ) + + ;; arg-info : lifted-x -> unrenamed extra-arg* + ;; rename-info : unrenamed x -> renamed x + (Expr : Expr (ir lift-info arg-info rename-info level target) -> Expr () + [,x (rename rename-info x)] + + [(call ,info ,mdcl ,x ,[e*] ...) + (cond + [(find-extra-arg* x arg-info) + => + (lambda (x+extra-arg*) + `(call ,info ,mdcl ,(rename rename-info x) + ,(append (map (rename rename-info) (cdr x+extra-arg*)) e*) ...))] + [else + `(call ,info ,mdcl ,(rename rename-info x) ,e* ...)])] + + [(let ([,x* ,[e*]] ...) ,body) + (with-level [x* level] + `(let ([,x* ,e*] ...) ,(recur Expr body)))] + + [(mvlet ,[e] ((,x** ...) ,interface* ,body*) ...) + `(mvlet ,e + ((,x** ...) + ,interface* + ,(map (lambda (x* body) + (with-level [x* level] + (recur Expr body))) + x** body*)) + ...)] + [(loop ,x (,x* ...) ,body) + (with-level [(list x) level] + `(loop ,x (,x* ...) ,(recur Expr body)))] + + ;; a lift barrier on this level + [(closures ([,x* (,x** ...) ,le*] ...) ,body) + (guard (fx= level target)) + (with-level [x* level] + (let f ([x* x*] [x** x**] [le* le*] [rx* '()] [rfv** '()] [rle* '()]) + (cond + [(null? x*) + `(closures ([,(reverse rx*) (,(reverse rfv**) ...) ,(reverse rle*)] ...) + ,(recur Expr body))] + [else + (let*-values ([(new-lift-info) (make-lift-info)] + [(new-le) (let ([level (fx+ level 1)] [lift-info new-lift-info]) + (recur CaseLambdaExpr (car le*)))] + [(lift*) (apply append (lift-info-le** new-lift-info))]) + (f (cdr x*) (cdr x**) (cdr le*) + (append (map le-info-x lift*) (cons (car x*) rx*)) + (append (map le-info-fv* lift*) (cons (append (car x**) (map le-info-x lift*)) rfv**)) + (append (map le-info-cle lift*) (cons new-le rle*))))])))] + + [(closures ([,x* (,x** ...) ,le*] ...) ,body) + (let-values ([(lift-x* non-lift-x*) (partition-liftable x* x** le*)]) + (with-level [non-lift-x* level] + (with-lifts lift-x* + (let*-values ([(rest-le* lift-le* extra-arg**) (partition-lift x* x** le* target)] + [(extra-arg*) (union-extra-arg* lift-le* arg-info extra-arg**)] + [(arg-info) (append (map (lambda (le-info) + (cons (le-info-x le-info) extra-arg*)) + lift-le*) + arg-info)] + [(rest-le*) + (map (lambda (le-info) (recur rewrite-rest-le le-info)) + rest-le*)] + [(lift-le*) + (map (lambda (le-info) + (recur rewrite-lifted-le le-info extra-arg*)) + lift-le*)]) + (unless (null? lift-le*) + (lift-info-le**-set! lift-info (cons lift-le* (lift-info-le** lift-info)))) + (let ([body (recur Expr body)]) + (cond + [(null? rest-le*) body] + [else + `(closures ([,(map le-info-x rest-le*) (,(map le-info-fv* rest-le*) ...) + ,(map le-info-cle rest-le*)] ...) + ,body)]))))))]) + + (CaseLambdaClause : CaseLambdaClause (ir lift-info arg-info rename-info level target) -> CaseLambdaClause () + [(clause (,x* ...) ,mcp ,interface ,body) + (with-level [x* level] + (let* ([old-le** (lift-info-le** lift-info)] + [new-body (recur Expr body)]) + `(clause (,x* ...) + ,(or mcp + ;;introduce a cpvar if something lifted from this clause + (and (not (eq? (lift-info-le** lift-info) old-le**)) + (make-cpvar))) + ,interface ,new-body)))]) + (CaseLambdaExpr : CaseLambdaExpr (ir lift-info arg-info rename-info level target) -> CaseLambdaExpr () + [(case-lambda ,info ,cl* ...) + `(case-lambda + ,info + ,(if (info-lambda-lift-barrier? info) + (let ([target level]) + (map (lambda (cl) (recur CaseLambdaClause cl)) cl*)) + (map (lambda (cl) (recur CaseLambdaClause cl)) cl*)) + ...)]) + + (LiftedCaseLambdaClause : CaseLambdaClause (ir extra-arg* lift-info arg-info rename-info level target) -> CaseLambdaClause () + [(clause (,x* ...) ,mcp ,interface ,body) + (with-level [x* level] + (let* ([new-extra-arg* (map make-renamed extra-arg*)] + [n (length new-extra-arg*)] + [new-rename-info (append (map cons extra-arg* new-extra-arg*) rename-info)] + [old-le** (lift-info-le** lift-info)] + [new-body (let ([rename-info new-rename-info]) + (recur Expr body))] + [new-interface (cond + [(fx< interface 0) (fx- interface n)] + [else (fx+ interface n)])]) + `(clause (,(append new-extra-arg* x*) ...) + ,(or mcp + ;;introduce a cpvar if something lifted from this clause + (and (not (eq? (lift-info-le** lift-info) old-le**)) + (make-cpvar))) + ,new-interface ,new-body)))]) + + (LiftedCaseLambdaExpr : CaseLambdaExpr (ir extra-arg* lift-info arg-info rename-info level target) -> CaseLambdaExpr (lift-x*) + [(case-lambda ,info ,cl* ...) + (let* ([new-lift-info (make-lift-info)] + [cl* (let ([lift-info new-lift-info]) + (if (info-lambda-lift-barrier? info) + (let ([target level]) + (map (lambda (cl) (recur LiftedCaseLambdaClause cl extra-arg*)) cl*)) + (map (lambda (cl) (recur LiftedCaseLambdaClause cl extra-arg*)) cl*)))] + [lift-x* (map le-info-x (apply append (lift-info-le** new-lift-info)))]) + (lift-info-le**-set! lift-info (append (lift-info-le** new-lift-info) (lift-info-le** lift-info))) + (values `(case-lambda ,info ,cl* ...) lift-x*))]) + + (CaseLambdaExpr ir (make-lift-info) '() '() 0 0)) + + (define np-lift-well-known-closures + (lambda (ir) + (let ([ir (np-lift ir)]) + (np-identify-scc ir))))) + (module (np-expand-closures np-expand/optimize-closures) (define sort-bindings ; sort-bindings uses the otherwise unneeded info-lambda-seqno to put labels @@ -18762,6 +19123,9 @@ (pass np-convert-closures unparse-L6) (pass np-optimize-direct-call unparse-L6) (pass np-identify-scc unparse-L6) + (if ($lift-closures) + (pass np-lift-well-known-closures unparse-L6) + (lambda (ir) ir)) (if ($optimize-closures) (pass np-expand/optimize-closures unparse-L7) (pass np-expand-closures unparse-L7)) @@ -18807,4 +19171,6 @@ (set! $track-static-closure-counts track-static-closure-counts) (set! $optimize-closures (make-parameter #t (lambda (x) (and x #t)))) + + (set! $lift-closures (make-parameter #t (lambda (x) (and x #t)))) ) diff --git a/racket/src/ChezScheme/s/cprep.ss b/racket/src/ChezScheme/s/cprep.ss index 711aaf3e21..df2896a5e1 100644 --- a/racket/src/ChezScheme/s/cprep.ss +++ b/racket/src/ChezScheme/s/cprep.ss @@ -131,7 +131,8 @@ '(let $primitive quote begin case-lambda library-case-lambda lambda if set! letrec letrec* $foreign-procedure - $foreign-callable eval-when)))) + $foreign-callable eval-when + $lambda/lift-barrier)))) (nanopass-case (Lsrc Expr) x [(ref ,maybe-src ,x) (get-name x)] [(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...) @@ -198,7 +199,10 @@ (lambda () (let ((cl* (map uncprep-lambda-clause cl*))) (if (and (not (null? cl*)) (null? (cdr cl*))) - `(lambda ,@(car cl*)) + (if (fx= (bitwise-and (constant code-flag-lift-barrier) (preinfo-lambda-flags preinfo)) + (constant code-flag-lift-barrier)) + `($lambda/lift-barrier ,@(car cl*)) + `(lambda ,@(car cl*))) `(case-lambda ,@cl*)))))] [(if ,[e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)] [(set! ,maybe-src ,x ,[e]) `(set! ,(get-name x) ,e)] diff --git a/racket/src/ChezScheme/s/front.ss b/racket/src/ChezScheme/s/front.ss index d6ff185fce..593b6093b0 100644 --- a/racket/src/ChezScheme/s/front.ss +++ b/racket/src/ChezScheme/s/front.ss @@ -170,6 +170,7 @@ compile-whole-library compile-whole-program ($dynamic-closure-counts compile) + ($lift-closures compile) ($loop-unroll-limit compile) make-boot-file ($make-boot-file make-boot-file) diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index 11e299c02b..0578e432c0 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/racket/src/ChezScheme/s/primdata.ss @@ -1044,6 +1044,7 @@ ) (define-symbol-flags* ([libraries] [flags keyword]) + ($lambda/lift-barrier [flags]) ($system [flags library-uid]) (add-prefix [flags]) (alias [flags]) @@ -2452,6 +2453,7 @@ ($enable-pass-timing [flags single-valued]) ($expeditor-history-file [feature expeditor] [flags single-valued]) ($fasl-target [flags single-valued]) + ($lift-closures [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) ($optimize-closures [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) ($suppress-primitive-inlining [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) ($sfd [flags single-valued]) diff --git a/racket/src/ChezScheme/s/syntax.ss b/racket/src/ChezScheme/s/syntax.ss index 5a9416b059..0ded1a2fce 100644 --- a/racket/src/ChezScheme/s/syntax.ss +++ b/racket/src/ChezScheme/s/syntax.ss @@ -501,7 +501,7 @@ (if src `(seq (profile ,src) ,e) e)) e))) -(module (build-lambda build-library-case-lambda build-case-lambda) +(module (build-lambda build-lambda/lift-barrier build-library-case-lambda build-case-lambda) (define build-clause (lambda (fmls body) (let f ((ids fmls) (n 0)) @@ -528,6 +528,12 @@ `(case-lambda ,(make-preinfo-lambda (ae->src ae)) ,(build-clause vars exp))))) + (define build-lambda/lift-barrier + (lambda (ae vars exp) + (build-profile ae + `(case-lambda ,(make-preinfo-lambda (ae->src ae) #f #f #f (constant code-flag-lift-barrier)) + ,(build-clause vars exp))))) + (define build-case-lambda (lambda (ae clauses) (build-profile ae @@ -2704,7 +2710,7 @@ (make-ctdesc import-req* visit-visit-req* visit-req* #t #t '() #f #f) (make-rtdesc invoke-req* #t (top-level-eval-hook - (build-lambda no-source '() + (build-lambda/lift-barrier no-source '() (build-library-body no-source dl* db* dv* de* (build-sequence no-source `(,@inits ,(build-void))))))))) @@ -5614,7 +5620,7 @@ (lambda (uid dl* db* dv* de* body) (build-primcall no-source 3 '$install-library/rt-code (build-data no-source uid) - (build-lambda no-source '() + (build-lambda/lift-barrier no-source '() (build-library-body no-source dl* db* dv* de* body))))) (let () @@ -6216,6 +6222,13 @@ (let-values ([(vars body) (chi-lambda-clause (source-wrap e w ae) (syntax c) r w)]) (build-lambda ae vars body)))))) +(global-extend 'core '$lambda/lift-barrier + (lambda (e r w ae) + (syntax-case e () + ((_ . c) + (let-values ([(vars body) (chi-lambda-clause (source-wrap e w ae) (syntax c) r w)]) + (build-lambda/lift-barrier ae vars body)))))) + (global-extend 'core 'case-lambda (lambda (e r w ae) (syntax-case e ()