From 24be6703bfea91d77c33de2950e07b441d8f3e29 Mon Sep 17 00:00:00 2001
From: Gustavo Massaccesi <gustavo@oma.org.ar>
Date: Sat, 25 Jan 2020 23:25:05 -0300
Subject: [PATCH] cptypes: add support for call-with-values, apply and similar
 functions

In some procedures, one of the arguments is a function that will surely be called
and the result is the result of the whole expression. These procedures need an
special version of define-specialize that gives more control.

original commit: f2f0401d2b83313e8cb0d5742e89ed098500cbd6
---
 mats/cp0.ms     |   6 +-
 mats/cptypes.ms | 355 ++++++++++++++++++++++++++++++++++++++++++++++++
 s/cmacros.ss    |   2 +
 s/cptypes.ss    | 167 ++++++++++++++++++++++-
 s/primdata.ss   |  10 +-
 5 files changed, 530 insertions(+), 10 deletions(-)

diff --git a/mats/cp0.ms b/mats/cp0.ms
index 36941f4510..3669f36b8f 100644
--- a/mats/cp0.ms
+++ b/mats/cp0.ms
@@ -2255,10 +2255,10 @@
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       ;; don't fold primitive in test context with bad apply convention
-      (expand/optimize '(if (#%apply #%eof-object 1 2 3) 4 5)))
+      (expand/optimize '(if (#%apply #%pair? 1 2 3) 4 5)))
     (if (= (optimize-level) 3)
-        '(if (#3%apply #3%eof-object 1 2 3) 4 5)
-        '(if (#2%apply #2%eof-object 1 2 3) 4 5)))
+        '(if (#3%apply #3%pair? 1 2 3) 4 5)
+        '(if (#2%apply #2%pair? 1 2 3) 4 5)))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       ;; don't fold primitive in effect context with bad apply convention
diff --git a/mats/cptypes.ms b/mats/cptypes.ms
index 453bb55de0..92403d2d54 100644
--- a/mats/cptypes.ms
+++ b/mats/cptypes.ms
@@ -704,3 +704,358 @@
     '(lambda (b) (list (unbox b) (lambda (x) (box? b))))
     '(lambda (b) (list (unbox b) (lambda (x) #t))))
 )
+
+(mat cptypes-call-with-values
+  ; The single value case is handled by cp0
+  (cptypes-equivalent-expansion?
+    '(lambda (v)
+       (call-with-values
+        (lambda () (vector-ref v 0))
+        (lambda (y) (list (vector? v) (vector-ref v 1) y))))
+    '(lambda (v)
+       (call-with-values
+        (lambda () (vector-ref v 0))
+        (lambda (y) (list #t (vector-ref v 1) y)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (t)
+       (call-with-values
+        (lambda () (if t (box 2) (box 3)))
+        (lambda (y) (list y (box? y)))))
+    '(lambda (t)
+       (call-with-values
+        (lambda () (if t (box 2) (box 3)))
+        (lambda (y) (list y #t)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (t b)
+       (call-with-values
+        (lambda () (if t 1 2))
+        (lambda (y) (display (unbox b))))
+       (box? b))
+    '(lambda (t b)
+       (call-with-values
+        (lambda () (if t 1 2))
+        (lambda (y) (display (unbox b))))
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (call-with-values
+        (lambda () (if (unbox b) 1 2))
+        (lambda (y) (display y)))
+       (box? b))
+    '(lambda (b)
+       (call-with-values
+        (lambda () (if (unbox b) 1 2))
+        (lambda (y) (display y)))
+       #t))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (call-with-values
+        (lambda () (if (unbox b) 1 (values 2 3)))
+        (lambda (x y) (list x y (box? b)))))
+    '(lambda (b)
+       (call-with-values
+        (lambda () (if (unbox b) 1 (values 2 3)))
+        (lambda (x y) (list x y #t)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (t b)
+       (call-with-values
+        (lambda () (if t 1 (values 2 3)))
+        (lambda (x y) (display (list x y (unbox b)))))
+       (box? b))
+    '(lambda (t b)
+       (call-with-values
+        (lambda () (if t 1 (values 2 3)))
+        (lambda (x y) (display (list x y (unbox b)))))
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (call-with-values
+        (lambda () (if (unbox b) 1 (values 2 3)))
+        (lambda (x y) (display (list x y))))
+       (box? b))
+    '(lambda (b)
+       (call-with-values
+        (lambda () (if (unbox b) 1 (values 2 3)))
+        (lambda (x y) (display (list x y))))
+       #t))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (call-with-values
+        (case-lambda 
+          [() (if (unbox b) 1 (values 2 3))]
+          [(x) (error 'e "")])
+        (lambda (x y) (list x y (box? b)))))
+    '(lambda (b)
+       (call-with-values
+        (case-lambda 
+          [() (if (unbox b) 1 (values 2 3))]
+          [(x) (error 'e "")])
+        (lambda (x y) (list x y #t)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (t b)
+       (call-with-values
+        (lambda () (if t 1 (values 2 3)))
+        (case-lambda
+         [(x y) (display (list x y (unbox b)))]
+         [(x) (error 'e "")]))
+       (box? b))
+    '(lambda (t b)
+       (call-with-values
+        (lambda () (if t 1 (values 2 3)))
+        (case-lambda
+         [(x y) (display (list x y (unbox b)))]
+         [(x) (error 'e "")]))
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (call-with-values
+        (case-lambda 
+          [() (if (unbox b) 1 (values 2 3))]
+          [(x) (error 'e "")])
+        (lambda (x y) (display (list x y))))
+       (box? b))
+    '(lambda (b)
+       (call-with-values
+        (case-lambda 
+          [() (if (unbox b) 1 (values 2 3))]
+          [(x) (error 'e "")])
+        (lambda (x y) (display (list x y))))
+       #t))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (t b)
+       (call-with-values
+        (begin (display (unbox b)) (lambda () (if t 1 (values b 2))))
+        (lambda (x y) (list x y (box? b)))))
+    '(lambda (t b)
+       (call-with-values
+        (begin (display (unbox b)) (lambda () (if t 1 (values b 2))))
+        (lambda (x y) (list x y #t)))))
+  ; This is difficult to handle in cptypes, so I ignored it.
+  ; But it is anyway handled by cp0.
+  #;(cptypes-equivalent-expansion?
+      '(lambda (t b)
+         (call-with-values
+          (lambda () (if t 1 (values b (box? b))))
+          (begin (display (unbox b)) (lambda (x y) (list x y b)))))
+      '(lambda (t b)
+         (call-with-values
+          (lambda () (if t 1 (values b #t)))
+          (begin (display (unbox b)) (lambda (x y) (list x y b))))))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (t)
+       (number?
+        (call-with-values
+         (lambda () (if t 1 (values 2 3)))
+         (case-lambda [(x y) 2] [(x) 1]))))
+    '(lambda (t)
+       (call-with-values
+        (lambda () (if t 1 (values 2 3)))
+        (case-lambda [(x y) 2] [(x) 1]))
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (t)
+       (number?
+        (call-with-values
+         (lambda () (if t 1 (values 2 3)))
+         (case-lambda [(x y) 2] [(x) (error 'e "")]))))
+    '(lambda (t)
+       (call-with-values
+        (lambda () (if t 1 (values 2 3)))
+        (case-lambda [(x y) 2] [(x) (error 'e "")]))
+       #t))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (t f)
+       (call-with-values
+        (lambda () (if t 1 (values 2 3)))
+         f)
+       (procedure? f))
+    '(lambda (t f)
+       (call-with-values
+        (lambda () (if t 1 (values 2 3)))
+         f)
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (t f)
+       (call-with-values
+        f
+        (lambda (x y) (+ x y)))
+       (procedure? f))
+    '(lambda (t f)
+       (call-with-values
+        f
+        (lambda (x y) (+ x y)))
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (t f)
+       (when (box? f)
+         (call-with-values
+          (lambda () (if t 1 (values 2 3)))
+          f)
+         111))
+    '(lambda (t f)
+       (when (box? f)
+         (call-with-values
+          (lambda () (if t 1 (values 2 3)))
+          f)
+         222)))
+  (cptypes-equivalent-expansion?
+    '(lambda (t f)
+       (when (box? f)
+         (call-with-values
+          f
+          (lambda (x y) (+ x y)))
+         111))
+    '(lambda (t f)
+       (when (box? f)
+         (call-with-values
+          f
+          (lambda (x y) (+ x y)))
+         222)))
+)
+
+(mat cptypes-apply
+  (cptypes-equivalent-expansion?
+    '(lambda (l b)
+       (apply (lambda (x) (display (list (unbox b) x))) l)
+       (box? b))
+    '(lambda (l b)
+       (apply (lambda (x) (display (list (unbox b) x))) l)
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (l b)
+       (apply (lambda (x y) (display (list (unbox b) x))) 7 l)
+       (box? b))
+    '(lambda (l b)
+       (apply (lambda (x y) (display (list (unbox b) x))) 7 l)
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (l b)
+       (apply (lambda (x) (display (list b x))) (unbox b))
+       (box? b))
+    '(lambda (l b)
+       (apply (lambda (x) (display (list b x))) (unbox b))
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (l b)
+       (apply (lambda (x y) (display (list b x y))) 7 (unbox b))
+       (box? b))
+    '(lambda (l b)
+       (apply (lambda (x y) (display (list b x y))) 7 (unbox b))
+       #t))
+
+  (cptypes-equivalent-expansion?
+    ; with #3% the argument may be inlined and then executed in reverse order
+    '(lambda (l b)
+       (#2%apply (lambda (x y) (list (box? b) x y)) 7 (unbox b)))
+    '(lambda (l b)
+       (#2%apply (lambda (x y) (list #t x y)) 7 (unbox b))))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (l b)
+       (apply
+        (case-lambda 
+          [(x) (list (unbox b) x)]
+          [(x y) (error 'e "")])
+        l)
+       (box? b)) 
+    '(lambda (l b)
+       (apply
+        (case-lambda 
+          [(x) (list (unbox b) x)]
+          [(x y) (error 'e "")])
+        l)
+       #t)) 
+
+  (cptypes-equivalent-expansion?
+    '(lambda (l)
+       (number?
+        (apply (lambda (x y) (+ x y)) l)))
+    '(lambda (l)
+       (apply (lambda (x y) (+ x y)) l)
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (l)
+       (number?
+        (apply
+         (case-lambda
+          [(x y) (+ x y)]
+          [()  (error 'e "")])
+         l)))
+    '(lambda (l)
+       (apply
+        (case-lambda
+         [(x y) (+ x y)]
+         [()  (error 'e "")])
+        l)
+       #t))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (f l)
+       (apply f l)
+       (procedure? f))
+    '(lambda (f l)
+       (apply f l)
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (t f)
+       (when (box? f)
+         (apply f l)
+         111))
+    '(lambda (t f)
+       (when (box? f)
+         (apply f l)
+         222)))
+)
+
+(mat cptypes-dynamic-wind
+  (cptypes-equivalent-expansion?
+    '(lambda (f)
+       (box? (dynamic-wind (lambda (x) #f) (lambda () (box (f))) (lambda () #f))))
+    '(lambda (f)
+       (begin
+         (dynamic-wind (lambda (x) #f) (lambda () (box (f))) (lambda () #f))
+         #t)))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #f))
+       (box? b))
+    '(lambda (b)
+       (dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #f))
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (dynamic-wind (lambda (x) #f) (lambda () (unbox b)) (lambda () #f))
+       (box? b))
+    '(lambda (b)
+       (dynamic-wind (lambda (x) #f) (lambda () (unbox b)) (lambda () #f))
+       #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (dynamic-wind (lambda (x) #f) (lambda () #f) (lambda () (unbox b)))
+       (box? b))
+    '(lambda (b)
+       (dynamic-wind (lambda (x) #f) (lambda () #f) (lambda () (unbox b)))
+       #t))
+
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (dynamic-wind (lambda (x) (unbox b)) (lambda () (box? b)) (lambda () #f)))
+    '(lambda (b)
+       (dynamic-wind (lambda (x) (unbox b)) (lambda () #t) (lambda () #f))))
+  (cptypes-equivalent-expansion?
+    '(lambda (b)
+       (dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () (box? b))))
+    '(lambda (b)
+       (dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #t) )))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (b)
+            (dynamic-wind (lambda () #f) (lambda (x) (unbox b)) (lambda () (box? b))))
+         '(lambda (b)
+            (dynamic-wind (lambda () #f) (lambda (x) (unbox b)) (lambda () #t)))))
+)
diff --git a/s/cmacros.ss b/s/cmacros.ss
index 78ea2ae269..e91af671db 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -1671,6 +1671,8 @@
   (safeongoodargs           #b00100000000000000000000)
   (cptypes2                 #b01000000000000000000000)
   (cptypes3                 cptypes2)
+  (cptypes2x                cptypes2)
+  (cptypes3x                cptypes2)
   (arith-op                 (or proc pure true))
   (alloc                    (or proc discard true))
   ; would be nice to check that these and only these actually have cp0 partial folders
diff --git a/s/cptypes.ss b/s/cptypes.ss
index 1e58530352..8001bf1519 100644
--- a/s/cptypes.ss
+++ b/s/cptypes.ss
@@ -776,6 +776,74 @@ Notes:
                                         body))])
                        ($sputprop 'prim 'key handler)) ...)))])))
 
+      ; Similar to define-specialize, but the arguments are not analyzed yet,
+      ; so it's necesary to use Expr, Expr/call or a similar function to analyze them.
+      ; Also, the variables ret, ntypes and (get-type <arg>) are not available.
+      (define-syntax define-specialize/unrestricted
+        (lambda (x)
+          (define (make-get-type-name id)
+            (datum->syntax-object id
+              (gensym (string-append (symbol->string (syntax->datum id))
+                                     "-ret-type"))))
+          (syntax-case x ()
+            [(_key lev prim clause ...)
+             (identifier? #'prim)
+             #'(_key lev (prim) clause ...)]
+            [(_key lev (prim ...) clause ...)
+             (andmap identifier? #'(prim ...))
+             (with-implicit (_key level prim-name preinfo pr ctxt oldtypes)
+               (with-syntax
+                 ([key (case (datum lev)
+                         [(2) #'cptypes2x]
+                         [(3) #'cptypes3x]
+                         [else ($oops #f "invalid inline level ~s" (datum lev))])]
+                  [body
+                    (let loop ([clauses #'(clause ...)])
+                      (if (null? clauses)
+                          #'(unhandled preinfo pr e* ctxt oldtypes)
+                          (with-syntax ((rest (loop (cdr clauses))))
+                            (syntax-case (car clauses) ()
+                              [((x ...) b1 b2 ...)
+                               #;guard: (andmap identifier? #'(x ...))
+                               (with-syntax ([n (length #'(x ...))])
+                                 #'(if (eq? count n)
+                                       (apply (lambda (x ...)
+                                                b1 b2 ...) e*)
+                                       rest))]
+                              [(r b1 b2 ...)
+                               #;guard: (identifier? #'r)
+                               #'(apply
+                                  (lambda r
+                                    b1 b2 ...) e*)]
+                              [((x ... . r) b1 b2 ...)
+                               #;guard: (and (andmap identifier? #'(x ...)) (identifier? #'r))
+                               (with-syntax ([n (length #'(x ...))])
+                                 #'(if (fx>= count n)
+                                       (apply 
+                                         (lambda (x ... . r)
+                                           b1 b2 ...) e*)
+                                       rest))]))))])
+                 (for-each
+                   (lambda (sym-name)
+                     (let ([sym-key (datum key)])
+                       (if (getprop sym-name sym-key #f)
+                           (warningf #f "duplicate ~s handler for ~s" sym-key sym-name)
+                           (putprop sym-name sym-key #t))
+                       (unless (all-set?
+                                 (case (datum lev)
+                                   [(2) (prim-mask cptypes2x)]
+                                   [(3) (prim-mask cptypes3x)])
+                                 ($sgetprop sym-name '*flags* 0))
+                         (warningf #f "undeclared ~s handler for ~s~%" sym-key sym-name))))
+                   (datum (prim ...)))
+                 #'(begin
+                     (let ([handler (lambda (preinfo pr e* ctxt oldtypes unhandled)
+                                      (let ([level (if (all-set? (prim-mask unsafe) (primref-flags pr)) 3 2)]    
+                                            [prim-name 'prim]
+                                            [count (length e*)])
+                                        body))])
+                       ($sputprop 'prim 'key handler)) ...)))])))
+
       (define-syntax (get-type stx)
         (lambda (lookup)
           (syntax-case stx ()
@@ -859,6 +927,84 @@ Notes:
                  [else
                   (values `(call ,preinfo ,pr ,n) ret ntypes #f #f)]))])
 
+      (define-specialize/unrestricted 2 call-with-values
+        [(e1 e2) (let-values ([(e1 ret1 types1 t-types1 f-types1)
+                               (Expr/call e1 'value oldtypes oldtypes)])
+                   (let-values ([(e2 ret2 types2 t-types2 f-types2)
+                                 (Expr/call e2 ctxt types1 oldtypes)])
+                     (values `(call ,preinfo ,pr ,e1 ,e2)
+                             (if (predicate-implies? ret1 'bottom) ; check if necesary
+                                 'bottom
+                                 ret2)
+                             types2 t-types2 f-types2)))])
+
+      (define-specialize/unrestricted 2 apply
+        [(proc . e*) (let-values ([(e* r* t* t-t* f-t*)
+                                   (map-values 5 (lambda (e) (Expr e 'value oldtypes)) e*)])
+                     (let ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)])
+                       (let-values ([(proc retproc typesproc t-typesproc f-typesproc)
+                                     (Expr/call proc ctxt mtypes oldtypes)])
+                         (values `(call ,preinfo ,pr ,proc ,e* ...)
+                                 retproc typesproc t-typesproc f-typesproc))))])
+
+      (define-specialize/unrestricted 2 $apply
+        [(proc n args) (let*-values ([(n rn tn t-tn f-tn)
+                                      (Expr n 'value oldtypes)]
+                                     [(args rargs targs t-targs f-targs)
+                                      (Expr args 'value oldtypes)])
+                         (let* ([predn (primref->argument-predicate pr 1 #t)]
+                                [tn (if (predicate-implies-not? rn predn)
+                                        'bottom
+                                        tn)]
+                                [tn (pred-env-add/ref tn n predn)]
+                                [predargs (primref->argument-predicate pr 2 #t)]
+                                [targs (if (predicate-implies-not? rargs predargs)
+                                        'bottom
+                                        targs)]
+                                [targs (pred-env-add/ref targs args predargs)]
+                                [mtypes (pred-env-intersect/base tn targs oldtypes)])
+                           (let-values ([(proc retproc typesproc t-typesproc f-typesproc)
+                                         (Expr/call proc ctxt mtypes oldtypes)])
+                             (values `(call ,preinfo ,pr ,proc ,n ,args)
+                                     retproc typesproc t-typesproc f-typesproc))))])
+
+      (let ()
+        (define (handle-dynamic-wind critical? in body out ctxt oldtypes)
+          (let*-values ([(critical? rcritical? tcritical? t-tcritical? f-tcritical?)
+                         (if critical?
+                             (Expr critical? 'value oldtypes)
+                             (values #f #f oldtypes #f #f))]
+                        [(ìn rin tin t-tin f-tin)
+                         (Expr/call in 'value tcritical? oldtypes)]
+                        [(body rbody tbody t-tbody f-tbody)
+                         (Expr/call body 'value tin oldtypes)] ; it's almost possible to use ctxt instead of 'value here
+                        [(out rout tout t-tout f-tout)
+                         (Expr/call out 'value tin oldtypes)]) ; use tin instead of tbody in case of error or jump.
+            (let* ([n-types (pred-env-intersect/base tbody tout tin)]
+                   [t-types (and (eq? ctxt 'test)
+                                 t-tbody
+                                 (pred-env-rebase t-tbody tin n-types))]
+                   [f-types (and (eq? ctxt 'test)
+                                 f-tbody
+                                 (pred-env-rebase f-tbody tin n-types))])
+              (values critical? in body out rbody n-types t-types f-types))))
+        
+        (define-specialize/unrestricted 2 r6rs:dynamic-wind
+          [(in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
+                                       (handle-dynamic-wind #f in body out ctxt oldtypes)])
+                           (values `(call ,preinfo ,pr ,in ,body ,out)
+                                   ret n-types t-types f-types))])
+        (define-specialize/unrestricted 2 dynamic-wind
+          [(in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
+                                       (handle-dynamic-wind #f in body out ctxt oldtypes)])
+                           (values `(call ,preinfo ,pr ,in ,body ,out)
+                                   ret n-types t-types f-types))]
+          [(critical? in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
+                                                 (handle-dynamic-wind critical? in body out ctxt oldtypes)])
+                                     (values `(call ,preinfo ,pr ,critical? ,in ,body ,out)
+                                             ret n-types t-types f-types))])
+      )
+
   ))
 
   (with-output-language (Lsrc Expr)
@@ -884,7 +1030,24 @@ Notes:
                  #f)])))
 
   (define (fold-call/primref preinfo pr e* ctxt oldtypes)
-    (fold-primref/next preinfo pr e* ctxt oldtypes))
+    (fold-primref/unrestricted preinfo pr e* ctxt oldtypes))
+
+  (define (fold-primref/unrestricted preinfo pr e* ctxt oldtypes)
+    (let* ([flags (primref-flags pr)]
+           [prim-name (primref-name pr)]
+           [handler (or (and (all-set? (prim-mask unsafe) flags)
+                             (all-set? (prim-mask cptypes3x) flags)
+                             ($sgetprop prim-name 'cptypes3x #f))
+                        (and (all-set? (prim-mask cptypes2x) flags)
+                             ($sgetprop prim-name 'cptypes2x #f)))])
+      (if handler
+          (call-with-values
+            (lambda () (handler preinfo pr e* ctxt oldtypes fold-primref/next))
+            (case-lambda
+              [(ir2 ret2 types2 t-types2 f-types2)
+               (values ir2 ret2 types2 t-types2 f-types2)]
+              [else ($oops 'fold-primref "result of inline handler can't be #f")]))
+          (fold-primref/next preinfo pr e* ctxt oldtypes))))
 
   (define (fold-primref/next preinfo pr e* ctxt oldtypes)
     (let-values ([(t e* r* t* t-t* f-t*)
@@ -1340,7 +1503,7 @@ Notes:
             ; currently all the flags use the same bit
             (let ([used (map (lambda (key) (and (getprop sym key #f)
                                                 (begin (remprop sym 'cp02) #t)))
-                             '(cptypes2 cptypes3))])
+                             '(cptypes2 cptypes3 cptypes2x cptypes3x))])
               (when (andmap not used)
                 ($oops 'çptypes "no cptypes handler for ~s" sym))))))
       (oblist))
diff --git a/s/primdata.ss b/s/primdata.ss
index 9d3d85440d..5fbc2c7511 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -337,12 +337,12 @@
   (vector-for-each [sig [(procedure vector vector ...) -> (ptr ...)]] [flags cp03])
   (error [sig [(maybe-who string ptr ...) -> (bottom)]] [flags abort-op])
   (assertion-violation [sig [(maybe-who string ptr ...) -> (bottom)]] [flags abort-op])
-  (apply [sig [(procedure ptr ... list) -> (ptr ...)]] [flags cp02 ieee r5rs])
+  (apply [sig [(procedure ptr ... list) -> (ptr ...)]] [flags cp02 cptypes2x ieee r5rs])
   (call-with-current-continuation [sig [(procedure) -> (ptr ...)]] [flags ieee r5rs])
   (call/cc [sig [(procedure) -> (ptr ...)]] [flags])
   (values [sig [(ptr ...) -> (ptr ...)]] [flags unrestricted discard cp02 ieee r5rs])
-  (call-with-values [sig [(procedure procedure) -> (ptr ...)]] [flags cp02 ieee r5rs])
-  ((r6rs: dynamic-wind) [sig [(procedure procedure procedure) -> (ptr ...)]] [flags ieee r5rs])      ; restricted to 3 arguments
+  (call-with-values [sig [(procedure procedure) -> (ptr ...)]] [flags cp02 cptypes2x ieee r5rs])
+  ((r6rs: dynamic-wind) [sig [(procedure procedure procedure) -> (ptr ...)]] [flags cptypes2x ieee r5rs])      ; restricted to 3 arguments
 )
 
 (define-symbol-flags* ([libraries (rnrs) (rnrs bytevectors)] [flags keyword])
@@ -1270,7 +1270,7 @@
   (display-condition [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags])
   (display-statistics [sig [() (textual-output-port) -> (void)]] [flags true])
   (display-string [sig [(string) (string textual-output-port) -> (void)]] [flags true])
-  (dynamic-wind [sig [(procedure procedure procedure) (ptr procedure procedure procedure) -> (ptr ...)]] [flags ieee r5rs])
+  (dynamic-wind [sig [(procedure procedure procedure) (ptr procedure procedure procedure) -> (ptr ...)]] [flags cptypes2x ieee r5rs])
   (enable-interrupts [sig [() -> (uint)]] [flags true])
   (engine-block [sig [() -> (ptr)]] [flags])
   (engine-return [sig [(ptr ...) -> (bottom)]] [flags abort-op])
@@ -1785,7 +1785,7 @@
   ($allocate-thread-parameter [feature pthreads] [flags single-valued alloc])
   ($app [flags])
   ($app/no-inline [flags])
-  ($apply [sig [(procedure exact-integer list) -> (ptr ...)]] [flags])
+  ($apply [sig [(procedure exact-integer list) -> (ptr ...)]] [flags cptypes2x])
   ($assembly-output [flags single-valued])
   ($as-time-goes-by [flags])
   ($bignum-length [flags single-valued pure true])