ChezScheme: Add a pass to lift well-known closures

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)

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 ...)]))

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)

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*))

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))))
 )

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)]

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)

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])

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 ()