diff --git a/mats/4.ms b/mats/4.ms
index 7983a893e9..1fc72b10af 100644
--- a/mats/4.ms
+++ b/mats/4.ms
@@ -1304,9 +1304,9 @@
               (list 'b 'u 'y)
               (list 'c 'v 'z))))
     '(#2%list
-       (#2%string->symbol (#2%string-append "a" "b" "c"))
-       (#2%string->symbol (#2%string-append "t" "u" "v"))
-       (#2%string->symbol (#2%string-append "x" "y" "z"))))
+       (#3%string->symbol (#3%string-append "a" "b" "c"))
+       (#3%string->symbol (#3%string-append "t" "u" "v"))
+       (#3%string->symbol (#3%string-append "x" "y" "z"))))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
diff --git a/mats/Mf-base b/mats/Mf-base
index db0fd1aed7..f19e650bdc 100644
--- a/mats/Mf-base
+++ b/mats/Mf-base
@@ -125,7 +125,7 @@ ecpf = $(defaultecpf)
 
 # set of mats to run
 mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread\
- misc cp0 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\
+ misc cp0 cptypes 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\
  ftype unix windows examples ieee date exceptions oop
 
 Examples = ../examples
diff --git a/mats/cp0.ms b/mats/cp0.ms
index 61ea35c257..20528cbd9b 100644
--- a/mats/cp0.ms
+++ b/mats/cp0.ms
@@ -849,13 +849,13 @@
            (lambda (r)
              (emit-word! 2953052161)
              (emit-word! 3766812992)
-             (emit-word! (#2%+ 3766747136 (#2%ash r 0))))))
+             (emit-word! (#3%+ 3766747136 (#2%ash r 0))))))
       (syntax-case x ($primitive)
         [(set! test
            (lambda (r1)
              (ew1! 2953052161)
              (ew2! 3766812992)
-             (ew3! (#2%+ 3766747136 (#2%ash r2 0)))))
+             (ew3! (#3%+ 3766747136 (#2%ash r2 0)))))
          (eq? #'r1 #'r2)])))
  ; verify optimization of (if e s s) => (begin e s)
   (equivalent-expansion?
@@ -893,14 +893,14 @@
       (expand/optimize
         '(lambda (x y) (if (not (or (fx< x y) (fx> y x))) x y))))
     '(lambda (x.0 y.1)
-       (if (if (#2%fx< x.0 y.1) #t (#2%fx> y.1 x.0))
+       (if (if (#2%fx< x.0 y.1) #t (#3%fx> y.1 x.0))
            y.1
            x.0)))
   (equivalent-expansion?
     (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
       (expand/optimize
         '(lambda (x y) (if (or (fx< x y) (fx> y x)) x y))))
-    '(lambda (x y) (if (if (#2%fx< x y) #t (#2%fx> y x)) x y)))
+    '(lambda (x y) (if (if (#2%fx< x y) #t (#3%fx> y x)) x y)))
   (equivalent-expansion?
     (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2])
       (expand/optimize
diff --git a/mats/cptypes.ms b/mats/cptypes.ms
new file mode 100644
index 0000000000..0f06b004cb
--- /dev/null
+++ b/mats/cptypes.ms
@@ -0,0 +1,697 @@
+;;; cptypes.ms
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-syntax cptypes-equivalent-expansion?
+  (syntax-rules ()
+    [(_ x y)
+     (equivalent-expansion?
+      (parameterize ([enable-cp0 #t]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize x))
+      (parameterize ([enable-cp0 #t]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize y)))]))
+
+(define-syntax cptypes/nocp0-equivalent-expansion?
+  (syntax-rules ()
+    [(_ x y)
+     (equivalent-expansion?
+      (parameterize ([enable-cp0 #f]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize x))
+      (parameterize ([enable-cp0 #f]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize y)))]))
+
+(define-syntax cptypes/nocp0/alternative-equivalent-expansion?
+  (syntax-rules ()
+    [(_ x y)
+     (equivalent-expansion?
+      (parameterize ([enable-cp0 #f]
+                     [enable-type-recovery #f]
+                     [run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize x))
+      (parameterize ([enable-cp0 #f]
+                     [enable-type-recovery #f]
+                     [run-cp0 (lambda (cp0 c) (#3%$cptypes c))]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize y)))]))
+
+(mat cptypes-handcoded
+  (cptypes-equivalent-expansion?
+    '(vector? (vector))  ;actually reduced by folding, not cptypes 
+    #t)
+  (cptypes-equivalent-expansion?
+    '(vector? (vector 1 2 3)) 
+    #t)
+  (cptypes-equivalent-expansion?
+    '(vector? (box 1)) 
+    #f)
+  (cptypes-equivalent-expansion?
+    '(box? (vector 1 2 3)) 
+    #f)
+  (cptypes-equivalent-expansion?
+    '(box? (box 1)) 
+    #t)
+  (cptypes-equivalent-expansion?
+    '(pair? (cons 1 2)) 
+    #t)
+  (cptypes-equivalent-expansion?
+    '(pair? (list 1 2)) 
+    #t)
+  (cptypes-equivalent-expansion?
+    '(pair? (list)) 
+    #f)
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (vector? x))
+    '(lambda (x) (vector-set! x 0 0) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (box? x))
+    '(lambda (x) (vector-set! x 0 0) #f))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (vector-set! x 0 0) (set! y (vector? x)))
+    '(lambda (x y) (vector-set! x 0 0) (set! y #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (set! y (vector-ref x 0)) (list (vector? x) y))
+    '(lambda (x y) (set! y (vector-ref x 0)) (list #t y)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list (vector? x) y y)))
+    '(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list #t y y))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (let ([y (vector? x)]) (list (random 7) y y)))
+    '(lambda (x) (vector-set! x 0 0) (let ([y #t]) (list (random 7) y y))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (let ([y (vector-ref x 0)]) (list (vector? x) y y)))
+    '(lambda (x) (let ([y (vector-ref x 0)]) (list #t y y))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (let ([y (vector-ref x 0)])
+                   (let ([z (vector? x)])
+                     (list y y z z))))
+    '(lambda (x) (let ([y (vector-ref x 0)])
+                   (let ([z #t])
+                     (list y y z z)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) (vector? x))
+    '(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) (vector? x))
+    '(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) #t))
+  (cptypes-equivalent-expansion?
+    '(let ([y (vector 1 2 3)]) (display (list (vector? y) y y)))
+    '(let ([y (vector 1 2 3)]) (display (list #t y y))))
+  (cptypes-equivalent-expansion?
+    '(let ([y (vector 1 2 3)]) (display (list y y)) (vector? y))
+    '(let ([y (vector 1 2 3)]) (display (list y y)) #t))
+  (cptypes-equivalent-expansion?
+    '(vector? (let ([y (vector 1 2 3)]) (display (list y y)) y))
+    '(begin (let ([y (vector 1 2 3)]) (display (list y y)) y) #t))
+  (cptypes-equivalent-expansion?
+    '(vector? (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6)))
+    '(begin (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6)) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (null? x) (display x)))
+    '(lambda (x) (when (null? x) (display '()))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (vector? x) (eq? x 'vector?)))
+    '(lambda (x) (when (vector? x) #f)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (vector? x) (pair? x)))
+    '(lambda (x) (when (vector? x) #f)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (vector? x) (vector? x)))
+    '(lambda (x) (when (vector? x) #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (procedure? x) (procedure? x)))
+    '(lambda (x) (when (procedure? x) #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (f) (f) (procedure? f))
+    '(lambda (f) (f) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (x)
+       (vector-set! x 0 0)
+       (let loop ([n 1000])
+         (unless (zero? n)
+           (display (vector? x))
+           (loop (- n 1)))))
+    '(lambda (x)
+       (vector-set! x 0 0)
+       (let loop ([n 1000])
+         (unless (zero? n)
+           (display #t)
+           (loop (- n 1))))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x)
+       (let loop ([n 1000])
+         (unless (zero? n)
+           (vector-set! x 0 n)
+           (loop (- n 1))))
+       (vector? x))
+    '(lambda (x)
+       (let loop ([n 1000])
+         (unless (zero? n)
+           (vector-set! x 0 n)
+           (loop (- n 1))))
+       (vector? x)))
+  (cptypes-equivalent-expansion?
+    '(begin (error 'who "msg") 1) ;could be reduced in cp0
+    '(begin (error 'who "msg") 2))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x) 1)
+    '(lambda (x) (vector-set! x) 2))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (#2%-) 1)
+    '(lambda (x) (#2%-) 2))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (#2%make-vector x 0 7) 1)
+    '(lambda (x) (#2%make-vector x 0 7) 2))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (set-box! x 0) 1)
+    '(lambda (x) (vector-set! x 0 0) (set-box! x 0) 2))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! (box 5) 0 0) 1)
+    '(lambda (x) (vector-set! (box 5) 0 0) 2))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (#2%odd? x) (real? x))
+    '(lambda (x) (#2%odd? x) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (#2%odd? x) 1)
+    '(lambda (x) (vector-set! x 0 0) (#2%odd? x) 2))
+)
+
+(mat cptypes-type-if
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (if (vector-ref x 0) (newline) (void)) (vector? x))
+    '(lambda (x) (if (vector-ref x 0) (newline) (void)) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (if (vector-ref x 0) (vector? x) (void)))
+    '(lambda (x) (if (vector-ref x 0) #t (void))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (if (vector-ref x 0) (void) (vector? x)))
+    '(lambda (x) (if (vector-ref x 0) (void) #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) (vector? x))
+    '(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) #t))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) (vector? x))
+         '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) #t)))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) (vector? x))
+         '(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (if x (newline) (void)))
+    '(lambda (x) (vector-set! x 0 0) (if #t (newline) (void))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (if (vector? x) (newline) (void)))
+    '(lambda (x) (vector-set! x 0 0) (if #t (newline) (void))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (vector? x) (if x (newline) (void))))
+    '(lambda (x) (when (vector? x) (if #t (newline) (void)))))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x) (when (boolean? x) (if x (newline) (void))))
+         '(lambda (x) (when (boolean? x) (if #t (newline) (void))))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (vector? x) (void)))
+    '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) #t (void))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) (vector? x)))
+    '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (if (vector? x) (vector? x) (void)))
+    '(lambda (x) (if (vector? x) #t (void))))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x) (if (vector? x) (void) (vector? x)))
+         '(lambda (x) (if (vector? x) (void) #t))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (if (vector? x) (if (vector? y) (list (vector? x) (vector? y)) (void)) (void)))
+    '(lambda (x y) (if (vector? x) (if (vector? y) (list #t #t) (void)) (void))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (if (and (vector? x) (vector? y)) (list (vector? x) (vector? y)) (void)))
+    '(lambda (x y) (if (and (vector? x) (vector? y)) (list #t #t) (void))))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x y) (if (or (vector? x) (vector? y)) (vector? x) (void)))
+         '(lambda (x y) (if (or (vector? x) (vector? y)) #t (void)))))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x y) (if (or (vector? x) (vector? y)) (vector? y) (void)))
+         '(lambda (x y) (if (or (vector? x) (vector? y)) #t (void)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (if (if (vector? x) (vector? y) #f) (list (vector? x) (vector? y)) (void)))
+    '(lambda (x y) (if (if (vector? x) (vector? y) #f) (list #t #t) (void))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) (vector? x)))
+    '(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) (number? x)))
+    '(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) #f)))
+  (cptypes-equivalent-expansion?
+    '(lambda (t) (let ([x (if t 1 2)]) (fixnum? x)))
+    '(lambda (t) (let ([x (if t 1 2)]) #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (t) (let ([x (if t 1 2.0)]) (number? x)))
+    '(lambda (t) (let ([x (if t 1 2.0)]) #t)))
+  (cptypes-equivalent-expansion?
+    '(if (error 'who "msg") (display 1) (display 2))
+    '(if (error 'who "msg") (display -1) (display -2)))
+  (cptypes-equivalent-expansion?
+    '(begin (if (error 'who "msg") (display 1) (display 2)) (display 3))
+    '(begin (if (error 'who "msg") (display 1) (display 2)) (display -3)))
+  (cptypes-equivalent-expansion?
+    '(begin (if (box? (box 0)) (error 'who "msg") (void)) (display 1))
+    '(begin (if (box? (box 0)) (error 'who "msg") (void)) (display -1)))
+  (not (cptypes-equivalent-expansion?
+         '(begin (if (box? (box 0)) (void) (error 'who "msg")) (display 1))
+         '(begin (if (box? (box 0)) (void) (error 'who "msg")) (display -1))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) (vector? x))
+    '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) (vector? x))
+    '(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) #t))
+  (cptypes-equivalent-expansion?
+    '(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display 1))
+    '(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display -1)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) (vector? x))
+    '(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) #t))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x y) (if y (void) (vector-set! x 0 0)) (vector? x))
+         '(lambda (x y) (if y (void) (vector-set! x 0 0)) #t)))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x y) (if y (vector-set! x 0 0) (void)) (vector? x))
+         '(lambda (x y) (if y (vector-set! x 0 0) (void)) #t)))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (vector? x) (void)))
+    '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) #t (void))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (vector? x) (void)))
+    '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) #t (void))))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) (vector? x)))
+         '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) #t))))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) (vector? x)))
+         '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) #t))))
+  (cptypes-equivalent-expansion?
+    '(lambda (t) (vector? (if t (vector 1) (vector 2))))
+    '(lambda (t) (if t (vector 1) (vector 2)) #t))
+  (cptypes-equivalent-expansion?
+    '(number? (if t 1 2.0))
+    '(begin (if t 1 2.0) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (t) (fixnum? (if t 1 2)))
+    '(lambda (t) (if t 1 2.0) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (t) (boolean? (if t #t #f)))
+    '(lambda (t) (if t #t #f) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (t) ((lambda (x) (if x #t #f)) (if t (vector 1) (box 1))))
+    '(lambda (t) (if t (vector 1) (box 1)) #t))
+  (cptypes-equivalent-expansion?
+    '(lambda (t)(not (if t (vector 1) (box 1))))
+    '(lambda (t) (if t (vector 1) (box 1)) #f))
+  (cptypes-equivalent-expansion?
+     '(lambda (x y z f)
+       (let ([t (if x (vector 1) (box 1))])
+         (if (if y t z) (f t 1) (f t 2))))
+     '(lambda (x y z f)
+       (let ([t (if x (vector 1) (box 1))])
+         (if (if y #t z) (f t 1) (f t 2)))))
+  (not (cptypes-equivalent-expansion?
+          '(lambda (x y z f)
+            (let ([t (vector? x)])
+              (if (if y t z) (f t 1) (f t 2))))
+          '(lambda (x y z f)
+            (let ([t (vector? x)])
+              (if (if y #t z) (f t 1) (f t 2))))))
+  (not (cptypes-equivalent-expansion?
+          '(lambda (x y z f)
+            (let ([t (vector? x)])
+              (if (if y t z) (f t 1) (f t 2))))
+          '(lambda (x y z f)
+            (let ([t (vector? x)])
+              (if (if y #f z) (f t 1) (f t 2))))))
+)
+
+(mat cptype-directly-applied-case-lambda
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval
+        '(let ([t ((lambda (x y) (cons y x)) 'a 'b)])
+           (list t t))))
+    '((b . a) (b . a)))
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval
+        '(let ([t ((lambda (x . y) (cons y x)) 'a 'b 'c 'd)])
+           (list t t))))
+    '(((b c d) . a) ((b c d) . a)))
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval
+        '(let ([t ((case-lambda
+                     [(x) (cons 'first x)]
+                     [(x y) (cons* 'second y x)]
+                     [(x . y) (cons* 'third y x)]) 'a 'b)])
+           (list t t))))
+    '((second b . a) (second b . a)))
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval
+        '(let ([t ((case-lambda
+                     [(x) (cons 'first x)]
+                     [(x y) (cons* 'second y x)]
+                     [(x . y) (cons* 'third y x)]) 'a 'b 'c)])
+           (list t t))))
+    '((third (b c) . a) (third (b c) . a)))
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval 
+        '(let ([t 'z])
+           ((lambda args (set! t (cons args t))) 'a 'b 'c)
+           t)))
+    '((a b c) . z))
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval 
+        '(let ([t 'z])
+           ((lambda args (set! t (cons args t))) 'a 'b 'c)
+           t)))
+    '((a b c) . z))
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval 
+        '(let ([t 'z])
+           ((lambda (x . y) (set! t (cons* y x t))) 'a 'b 'c)
+           t)))
+    '((b c) a . z))
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval 
+        '(let ([t 'z])
+           ((case-lambda 
+              [(x) (set! t (cons* 'first x t))]
+              [(x y) (set! t (cons* 'second y x t))]
+              [(x . y) (set! t (cons* 'third y x t))]) 'a 'b)
+           t)))
+    '(second b a . z))
+  (equal?
+    (parameterize ([enable-type-recovery #t]
+                   [run-cp0 (lambda (cp0 x) x)])
+      (eval 
+        '(let ([t 'z])
+           ((case-lambda 
+              [(x) (set! t (cons* 'first x t))]
+              [(x y) (set! t (cons* 'second y x t))]
+              [(x . y) (set! t (cons* 'third y x t))]) 'a 'b 'c 'd)
+           t)))
+    '(third (b c d) a . z))
+)
+
+(define (test-chain/preamble/self preamble check-self? l)
+  (let loop ([l l])
+    (if (null? l)
+        #t
+        (and (or (not check-self?)
+                 (cptypes-equivalent-expansion?
+                   `(let ()
+                      ,preamble
+                      (lambda (x) (when (,(car l) x) (,(car l) x))))
+                   `(let ()
+                      ,preamble
+                      (lambda (x) (when (,(car l) x) #t)))))
+             (let loop ([t (cdr l)])
+               (if (null? t)
+                   #t
+                   (and (cptypes-equivalent-expansion?
+                          `(let ()
+                             ,preamble
+                             (lambda (x) (when (,(car l) x) (,(car t) x))))
+                          `(let ()
+                             ,preamble
+                             (lambda (x) (when (,(car l) x) #t))))
+                        (not (cptypes-equivalent-expansion?
+                               `(let ()
+                                  ,preamble
+                                  (lambda (x) (when (,(car t) x) (,(car l) x))))
+                               `(let ()
+                                  ,preamble
+                                  (lambda (x) (when (,(car t) x) #t)))))
+                        (loop (cdr t)))))
+             (loop (cdr l))))))
+
+(define (test-chain l)
+  (test-chain/preamble/self '(void) #t l))
+
+(define (test-chain* l)
+  (test-chain/preamble/self '(void) #f l))
+
+(define (test-chain/preamble preamble l)
+  (test-chain/preamble/self preamble #t l))
+
+(define (test-chain*/preamble l)
+  (test-chain/preamble/self preamble #f l))
+
+(define (test-disjoint/preamble/self preamble check-self? l)
+  (let loop ([l l])
+    (if (null? l)
+        #t
+       (and (or (not check-self?)
+                (cptypes-equivalent-expansion?
+                  `(let ()
+                     ,preamble
+                     (lambda (x) (when (,(car l) x) (,(car l) x))))
+                  `(let ()
+                     ,preamble
+                     (lambda (x) (when (,(car l) x) #t)))))
+            (let loop ([t (cdr l)])
+              (if (null? t)
+                  #t
+                  (and (cptypes-equivalent-expansion?
+                         `(let ()
+                            ,preamble
+                            (lambda (x) (when (,(car l) x) (,(car t) x))))
+                         `(let ()
+                            ,preamble
+                            (lambda (x) (when (,(car l) x) #f))))
+                       (cptypes-equivalent-expansion?
+                         `(let ()
+                           ,preamble
+                           (lambda (x) (when (,(car t) x) (,(car l) x))))
+                         `(let ()
+                            ,preamble
+                            (lambda (x) (when (,(car t) x) #f))))
+                       (loop (cdr t)))))
+            (loop (cdr l))))))
+
+(define (test-disjoint l)
+  (test-disjoint/preamble/self '(void) #t l))
+
+(define (test-disjoint* l)
+  (test-disjoint/preamble/self '(void) #f l))
+
+(define (test-disjoint/preamble preamble l)
+  (test-disjoint/preamble/self preamble #t l))
+
+(define (test-disjoint*/preamble preamble l)
+  (test-disjoint/preamble/self preamble #f l))
+
+(mat cptypes-type-implies?
+  (test-chain '((lambda (x) (eq? x 0)) fixnum? #;exact-integer? real? number?))
+  (test-chain* '(fixnum? integer? real?))
+  (test-chain* '(fixnum? exact? number?)) ; exact? may raise an error
+  (test-chain* '((lambda (x) (eq? x (expt 256 100))) real? number?)) ; bignum?
+  (test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?))
+  (test-chain '(gensym? symbol?))
+  (test-chain '(not boolean?))
+  (test-chain '((lambda (x) (eq? x #t)) boolean?))
+  (test-chain* '(record? #3%$record?))
+  (test-chain* '((lambda (x) (eq? x car)) procedure?))
+  (test-chain* '(record-type-descriptor? #3%$record?))
+  (test-disjoint '(pair? box? #3%$record? number?
+                   vector? string? bytevector? fxvector? symbol?
+                   char? boolean? null? (lambda (x) (eq? x (void)))
+                   eof-object? bwp-object? procedure?))
+  (test-disjoint '(pair? box? real? gensym? not))
+  (test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? x #t))))
+  (test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? #t x))))
+  (test-disjoint '((lambda (x) (eq? x 0)) (lambda (x) (eq? x 1)) flonum?))
+  (test-disjoint '((lambda (x) (eqv? x 0.0)) (lambda (x) (eqv? x 1.0)) fixnum?))
+  (test-disjoint* '(list? record? vector?))
+  (not (test-disjoint* '(list? null?)))
+  (not (test-disjoint* '(list? pair?)))
+)
+
+; use a gensym to make expansions equivalent
+(define my-rec (gensym "my-rec"))
+(mat cptypes-type-record?
+  ; define-record
+  (parameterize ([optimize-level 2])
+    (cptypes-equivalent-expansion?
+      `(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
+      `(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) #t))))
+  (parameterize ([optimize-level 2])
+    (cptypes-equivalent-expansion?
+      `(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) (my-rec? x)))
+      `(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) #t))))
+  (cptypes-equivalent-expansion?
+    `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
+    `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
+  (cptypes-equivalent-expansion?
+    `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
+    `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
+
+  (test-chain/preamble `(define-record ,my-rec (a)) '(my-rec? #3%$record?))
+  (test-chain/preamble `(begin
+                          (define-record ,my-rec (a))
+                          (define-record ,(gensym "sub-rec") ,my-rec (b)))
+                       '(sub-rec? my-rec? #3%$record?))
+  (test-disjoint/preamble `(define-record ,my-rec (a)) '(my-rec? pair? null? not number?))
+  (test-disjoint/preamble `(begin
+                            (define-record ,my-rec (a))
+                            (define-record ,(gensym "other-rec") (a)))
+                       '(my-rec? other-rec?))
+
+  ; define-record-type
+  (parameterize ([optimize-level 2])
+    (cptypes-equivalent-expansion?
+      `(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
+      `(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) #t))))
+  (parameterize ([optimize-level 2])
+    (cptypes-equivalent-expansion?
+      `(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) (my-rec? x)))
+      `(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) #t))))
+  (cptypes-equivalent-expansion?
+    `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
+    `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
+  (cptypes-equivalent-expansion?
+    `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
+    `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
+
+  (test-chain/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? #3%$record?))
+  #;(test-chain/preamble `(begin
+                            (define-record-type ,my-rec (fields a))
+                            (define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b)))
+                         '(sub-rec? my-rec? #3%$record?))
+  (test-disjoint/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? pair? null? not number?))
+  #;(test-disjoint/preamble `(begin
+                              (define-record-type ,my-rec (fields a))
+                              (define-record-type ,(gensym "other-rec") (fields a)))
+                            '(my-rec? other-rec?))
+
+  ; define-record-type (sealed #t)
+  (parameterize ([optimize-level 2])
+    (cptypes-equivalent-expansion?
+      `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) (my-rec? x)))
+      `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) #t))))
+  (parameterize ([optimize-level 2])
+    (cptypes-equivalent-expansion?
+      `(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) (my-rec? x)))
+      `(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) #t))))
+  (cptypes-equivalent-expansion?
+    `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x)))
+    `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) #t)))
+  (cptypes-equivalent-expansion?
+    `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2)))
+    `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2))))
+
+  (test-chain/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? #3%$record?))
+  #;(test-chain/preamble `(begin
+                            (define-record-type ,my-rec (fields a))
+                            (define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b) (sealed #t)))
+                         '(sub-rec? my-rec? #3%$record?))
+  (test-disjoint/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? pair? null? not number?))
+  #;(test-disjoint/preamble `(begin
+                              (define-record-type ,my-rec (fields a) (sealed #t))
+                              (define-record-type ,(gensym "other-rec") (fields a) (sealed #t)))
+                            '(my-rec? other-rec?))
+  #;(test-disjoint/preamble `(begin
+                              (define-record-type ,my-rec (fields a) (sealed #t))
+                              (define-record-type ,(gensym "other-rec") (fields a)))
+                            '(my-rec? other-rec?))
+)
+
+(mat cptypes-unsafe
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (pair? x) (car x)))
+    '(lambda (x) (when (pair? x) (#3%car x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (pair? x) (cdr x)))
+    '(lambda (x) (when (pair? x) (#3%cdr x))))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x) (when (pair? x) (#2%cadr x)))
+         '(lambda (x) (when (pair? x) (#3%cadr x)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (fxmax x y)))
+    '(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (#3%fxmax x y))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (fxmax x y)))
+    '(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (#3%fxmax x y))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x) (fxmax x 5)))
+    '(lambda (x) (when (fixnum? x) (#3%fxmax x 5))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (fxmax x y z)))
+    '(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (#3%fxmax x y z))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x) (fxzero? x)))
+    '(lambda (x) (when (fixnum? x) (#3%fxzero? x))))
+  (not (cptypes-equivalent-expansion?
+         '(lambda (x) (when (number? x) (#2%odd? x)))
+         '(lambda (x) (when (number? x) (#3%odd? x)))))
+)
+
+(mat cptypes-rest-argument
+  (cptypes/nocp0-equivalent-expansion?
+    '((lambda (x . r) (pair? r)) 1)
+    '((lambda (x . r) #f) 1))
+  (cptypes/nocp0-equivalent-expansion?
+    '((lambda (x . r) (null? r)) 1)
+    '((lambda (x . r) #t) 1))
+  (cptypes/nocp0-equivalent-expansion?
+    '((lambda (x . r) (pair? r)) 1 2)
+    '((lambda (x . r) #t) 1 2))
+  (cptypes/nocp0-equivalent-expansion?
+    '((lambda (x . r) (null? r)) 1 2)
+    '((lambda (x . r) #f) 1 2))
+)
+
+(mat cptypes-rest-argument/alternative
+  (cptypes/nocp0/alternative-equivalent-expansion?
+    '((lambda (x . r) (pair? r)) 1)
+    '((lambda (x . r) #f) 1))
+  (cptypes/nocp0/alternative-equivalent-expansion?
+    '((lambda (x . r) (null? r)) 1)
+    '((lambda (x . r) #t) 1))
+  (cptypes/nocp0/alternative-equivalent-expansion?
+    '((lambda (x . r) (pair? r)) 1 2)
+    '((lambda (x . r) #t) 1 2))
+  (cptypes/nocp0/alternative-equivalent-expansion?
+    '((lambda (x . r) (null? r)) 1 2)
+    '((lambda (x . r) #f) 1 2))
+)
diff --git a/mats/misc.ms b/mats/misc.ms
index 05fdf0b754..9228ff0203 100644
--- a/mats/misc.ms
+++ b/mats/misc.ms
@@ -5058,7 +5058,7 @@
         '(if (#3%zero? (#3%random 1000))
              (begin (pariah (void)) (#3%display 0))
              (#3%display 1))
-        '(if (#2%zero? (#2%random 1000))
+        '(if (#3%zero? (#2%random 1000))
              (begin (pariah (void)) (#2%display 0))
              (#2%display 1))))
 )
diff --git a/mats/record.ms b/mats/record.ms
index 19e67f09ca..6e2ea32f5b 100644
--- a/mats/record.ms
+++ b/mats/record.ms
@@ -6375,9 +6375,7 @@
              (#3%$object-set! 'scheme-object b ,fixnum? g7))
            (#2%list
              (#3%record? b g5)
-             (begin
-               (if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6))
-               (#3%$object-ref 'scheme-object b ,fixnum?)))))))
+             (#3%$object-ref 'scheme-object b ,fixnum?))))))
     (equal?
       (let ()
         (define build-box
@@ -6407,13 +6405,9 @@
                  (record-mutator (make-record-type-descriptor
                                    name #f #f #f #f '#((mutable x))) 0)))
              (procedure? (useless 'useless-box-setter)))))
-      `(#2%procedure?
-         (let ([g0 (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))])
-           (lambda (g1 g2)
-             (if (#3%record? g1 g0)
-                 (#2%void)
-                 (#3%$record-oops 'moi g1 g0))
-             (#3%$object-set! 'scheme-object g1 ,fixnum? g2)))))
+      `(begin
+         (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))
+         #t))
     (let ()
       (define useless
         (lambda (name)
@@ -8592,9 +8586,7 @@
              (if b (frob-x x) 72)))))
     `(lambda (b)
        (if b
-           (begin
-             (#3%$record-oops 'frob-x 'x ',record-type-descriptor?)
-             (#3%$object-ref 'scheme-object 'x ,fixnum?))
+          (#3%$record-oops 'frob-x 'x ',record-type-descriptor?)
            72)))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
@@ -8793,7 +8785,7 @@
                     [r (inc r)]
                     [r (inc r)])
                r)))))
-    `(lambda (x) (#3%$record ',record-type-descriptor? 37 (#2%+ 1 (#2%+ 1 x)))))
+    `(lambda (x) (#3%$record ',record-type-descriptor? 37 (#3%+ 1 (#2%+ 1 x)))))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -8820,7 +8812,7 @@
                     [r (inc r)])
                r)))))
     '(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable a) (immutable b)) 'define-record-type)])
-       (lambda (x) (#3%$record rtd 37 (#2%+ 1 (#2%+ 1 x))))))
+       (lambda (x) (#3%$record rtd 37 (#3%+ 1 (#2%+ 1 x))))))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
diff --git a/s/Mf-base b/s/Mf-base
index e35cdb1202..937f768fcb 100644
--- a/s/Mf-base
+++ b/s/Mf-base
@@ -105,7 +105,7 @@ patch = patch
 
 # putting cpnanopass.patch early for maximum make --jobs=2 benefit
 patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\
- cp0.patch cpvalid.patch cpcommonize.patch cpletrec.patch\
+ cp0.patch cpvalid.patch cptypes.patch cpcommonize.patch cpletrec.patch\
  reloc.patch\
  compile.patch fasl.patch syntax.patch env.patch\
  read.patch interpret.patch ftype.patch strip.patch\
@@ -127,7 +127,7 @@ basesrc =\
  strnum.ss bytevector.ss 5_4.ss 5_6.ss 5_7.ss\
  event.ss 4.ss front.ss foreign.ss 6.ss print.ss newhash.ss\
  format.ss date.ss 7.ss cafe.ss trace.ss engine.ss\
- interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cpcommonize.ss cpletrec.ss inspect.ss\
+ interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss  cptypes.ss cpcommonize.ss cpletrec.ss inspect.ss\
  enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\
  exceptions.ss pretty.ss env.ss\
  fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss
@@ -149,7 +149,7 @@ macroobj =\
 allsrc =\
  ${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\
  base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\
- np-languages.ss bitset.ss
+ np-languages.ss bitset.ss fxmap.ss
 
 # doit uses a different Scheme process to compile each target
 doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates}
@@ -397,7 +397,7 @@ endif
 
 script.all: Mf-base
 
-script.all makescript: 
+script.all makescript:
 	echo '(reset-handler abort)'\
              '(for-each load (command-line-arguments))'\
              '(optimize-level $o)'\
@@ -495,7 +495,7 @@ primvars.so setup.so mkheader.so env.so: cmacros.so priminfo.so primref.ss
 setup.so: debug.ss
 
 ${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss
-cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss ${archincludes}
+cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes}
 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss
 inspect.$m: bitset.ss
 
diff --git a/s/base-lang.ss b/s/base-lang.ss
index 6f7f4bdd93..e935b3afef 100644
--- a/s/base-lang.ss
+++ b/s/base-lang.ss
@@ -14,14 +14,14 @@
 ;;; limitations under the License.
 
 (module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc
-         lookup-primref primref? primref-name primref-level primref-flags primref-arity
+         lookup-primref primref? primref-name primref-level primref-flags primref-arity primref-signatures
          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-libspec
          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?)
 
-  (module (lookup-primref primref? primref-name primref-flags primref-arity primref-level)
+  (module (lookup-primref primref? primref-name primref-flags primref-arity primref-signatures primref-level)
     (include "primref.ss")
 
     (define $lookup-primref
diff --git a/s/cmacros.ss b/s/cmacros.ss
index dba65de022..75038f58bc 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -1599,6 +1599,7 @@
   (abort-op                 #b00000100000000000000000)
   (unsafe                   #b00001000000000000000000)
   (unrestricted             #b00010000000000000000000)
+  (safeongoodargs           #b00100000000000000000000)
   (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/compile.ss b/s/compile.ss
index 606e9e806b..91301d83a9 100644
--- a/s/compile.ss
+++ b/s/compile.ss
@@ -551,6 +551,12 @@
     (when ($enable-check-prelex-flags)
       ($pass-time 'cpcheck-prelex-flags (lambda () (do-trace $cpcheck-prelex-flags x 'uncprep))))))
 
+(define cptypes
+  (lambda (x)
+    (if (enable-type-recovery)
+        ($pass-time 'cptypes (lambda () ($cptypes x)))
+        x)))
+
 (define compile-file-help
   (lambda (op hostop wpoop machine sfd do-read outfn)
     (include "types.ss")
@@ -569,7 +575,8 @@
                    [$compile-profile ($compile-profile)]
                    [generate-interrupt-trap (generate-interrupt-trap)]
                    [$optimize-closures ($optimize-closures)]
-                   [enable-cross-library-optimization (enable-cross-library-optimization)])
+                   [enable-cross-library-optimization (enable-cross-library-optimization)]
+                   [enable-type-recovery (enable-type-recovery)])
       (emit-header op (constant machine-type))
       (when hostop (emit-header hostop (host-machine-type)))
       (when wpoop (emit-header wpoop (host-machine-type)))
@@ -650,14 +657,18 @@
                                     (set! cpletrec-ran? #t)
                                     (let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))]
                                            [waste (check-prelex-flags x 'cp0)]
+                                           [x (cptypes x)]
+                                           [waste (check-prelex-flags x 'cptypes)]
                                            [x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
                                            [waste (check-prelex-flags x 'cpletrec)])
                                       x))
                                   x2)])
                           (if cpletrec-ran?
                               x
-                              (let ([x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))])
-                                (check-prelex-flags x 'cpletrec)
+                              (let* ([x (cptypes x)]
+                                     [waste (check-prelex-flags x 'cptypes)]
+                                     [x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
+                                     [waste (check-prelex-flags x 'cpletrec)])
                                 x))))]
                  [x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))]
                  [waste (check-prelex-flags x2b 'cpcheck)]
@@ -1489,10 +1500,13 @@
                         (let ([x ((run-cp0)
                                   (lambda (x)
                                     (set! cpletrec-ran? #t)
-                                    (let ([x ($pass-time 'cp0 (lambda () ($cp0 x)))])
+                                    (let* ([x ($pass-time 'cp0 (lambda () ($cp0 x)))]
+                                           [x (cptypes x)])
                                       ($pass-time 'cpletrec (lambda () ($cpletrec x)))))
                                   x2)])
-                          (if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))]
+                          (if cpletrec-ran? x
+                              (let ([x (cptypes x)])
+                                ($pass-time 'cpletrec (lambda () ($cpletrec x)))))))]
                  [x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]
                  [x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))])
             (when (and (expand/optimize-output) (not ($noexpand? x0)))
diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss
index 67b4280061..d4b8272ffd 100644
--- a/s/cpnanopass.ss
+++ b/s/cpnanopass.ss
@@ -4556,6 +4556,7 @@
             [(e1 e2) (dofxlogbit1 e2 e1)])
           (define-inline 3 fxcopy-bit
             [(e1 e2 e3)
+             ;; NB: even in the case where e3 is not known to be 0 or 1, seems like we could do better here.
              (and (fixnum-constant? e3)
                   (case (constant-value e3)
                     [(0) (dofxlogbit0 e1 e2)]
diff --git a/s/cprep.ss b/s/cprep.ss
index 4be34de771..2900cbc432 100644
--- a/s/cprep.ss
+++ b/s/cprep.ss
@@ -215,6 +215,10 @@
       (if (eq? (subset-mode) 'system)
           ($system-environment)
           (interaction-environment)))
+    (define (cptypes x)
+      (if (enable-type-recovery)
+          ($cptypes x)
+          x))
     (define e/o
       (lambda (who cte? x env)
         (define (go x)
@@ -225,9 +229,9 @@
                   (let ([x ((run-cp0)
                             (lambda (x)
                               (set! cpletrec-ran? #t)
-                              ($cpletrec ($cp0 x $compiler-is-loaded?)))
+                              ($cpletrec (cptypes ($cp0 x $compiler-is-loaded?))))
                             ($cpvalid x))])
-                    (if cpletrec-ran? x ($cpletrec x))))))))
+                    (if cpletrec-ran? x ($cpletrec (cptypes x)))))))))
         (unless (environment? env)
           ($oops who "~s is not an environment" env))
         ; claim compiling-a-file to get cte as well as run-time code
diff --git a/s/cptypes.ss b/s/cptypes.ss
new file mode 100644
index 0000000000..9d42b73fa8
--- /dev/null
+++ b/s/cptypes.ss
@@ -0,0 +1,1058 @@
+"cptypes.ss"
+;;; cptypes.ss
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+#|
+Notes:
+ - (cptypes ir ctxt types) -> (values ir ret types t-types f-types)
+   + arguments
+     ir: expression to be optimized
+     ctxt: 'effect 'test 'value
+     types: an immutable dictionary (currently an intmap).
+            The dictionary connects the counter of a prelex with the types
+            discovered previously.
+            (fxmap ([prelex-counter x] . 'pair)
+                   ([prelex-counter y] . 'vector)
+                   ([prelex-counter z] . `(quote 0)))
+   + results
+     ir: the optimized expression
+     ret: type of the result of the expression
+     types: like the types in the argument, with the addition of the types
+            discover during the optimization of the expression
+     t-types: types to be used in case the expression is not #f, to be used in
+              the "then" branch of an if.
+              This is usually only filled in a text context.
+              It may be #f, and in this case the `if` clause will use the value
+              of types as a replacement.
+              (Also the clauses for `let[rec/*]` handle the #f case specialy.)
+     f-types: idem for the "else" branch. (if x (something) <here x is #f>)
+
+
+ - predicate: They may be:
+              * a symbol to indicate the type, like 'vector 'pair 'number
+                (there are a few fake values, in particular 'bottom is used to
+                 signal that there is an error)
+              * a nanopass-quoted value that is okay-to-copy?, like
+                `(quote 0) `(quote 5) `(quote #t) `(quote '())
+                (this doesn't includes `(quote <record-type-descriptor>))
+              * a record #[pred-$record/rtd <rtd>] to signal that it's a
+                record of type <rtd>
+              * a record #[pred-$record/ref <ref>] to signal that it's a
+                record of a type that is stored in the variable <ref>
+                (these may collide with other records)
+              * TODO?: add something to indicate that x is a procedure to
+                       create/setter/getter/predicate of a record of that type
+
+ - Primitives are marked as procedures, without distinction.
+ - Most of the time I'm using eq? and eqv? as if they were equivalent.
+   I assume that the differences are hidden by unspecified behavior.
+
+|#
+
+
+(define $cptypes)
+(let ()
+  (import (nanopass))
+  (include "base-lang.ss")
+  (include "fxmap.ss")
+
+  (define-pass cptypes : Lsrc (ir) -> Lsrc ()
+    (definitions
+  (define prelex-counter
+    (let ()
+      (define count 0)
+      (lambda (x)
+        (or (prelex-operand x)
+            (let ([c count])
+              (set! count (fx+ count 1))
+              (prelex-operand-set! x c)
+              c)))))
+
+  (with-output-language (Lsrc Expr)
+    (define void-rec `(quote ,(void)))
+    (define true-rec `(quote #t))
+    (define false-rec `(quote #f))
+    (define null-rec `(quote ()))
+    (define empty-vector-rec `(quote #()))
+    (define empty-string-rec `(quote ""))
+    (define empty-bytevector-rec `(quote #vu8()))
+    (define empty-fxvector-rec `(quote #vfx()))
+    (define eof-rec `(quote #!eof))
+    (define bwp-rec `(quote #!bwp))
+
+    (define (simple? e) ; Simplified version copied from cp0. TODO: copy the rest.
+      (nanopass-case (Lsrc Expr) e
+        [(quote ,d) #t]
+        [(ref ,maybe-src ,x) #t]
+        [(case-lambda ,preinfo ,cl* ...) #t]
+        [,pr #t]
+        [(moi) #t]
+        [(record-type ,rtd ,e) (simple? e)]
+        [else #f]
+        #;[else ($oops who "unrecognized record ~s" e)]))
+
+    ; TODO: Remove discardable operations in e1. (vector (f) (g)) => (begin (f) (g))
+    (define make-seq
+      ; ensures that the right subtree of the output seq is not a seq if the
+      ; second argument is similarly constrained, to facilitate result-exp
+      (lambda (ctxt e1 e2)
+        (if (simple? e1)
+            e2
+            (if (and (eq? ctxt 'effect) (simple? e2))
+                e1
+                (let ([e1 (nanopass-case (Lsrc Expr) e1
+                            [(seq ,e11 ,e12)
+                             (guard (simple? e12))
+                             e11]
+                            [else e1])])
+                  (nanopass-case (Lsrc Expr) e2
+                    [(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)]
+                    [else `(seq ,e1 ,e2)]))))))
+
+    #;(define make-seq* ; requires at least one operand
+        (lambda (ctxt e*)
+          (if (null? (cdr e*))
+              (car e*)
+              (make-seq ctxt (car e*) (make-seq* ctxt (cdr e*))))))
+  )
+
+  (define-record-type pred-$record/rtd
+    (fields rtd)
+    (nongenerative #{pred-$record/rtd wnquzwrp8wl515lhz2url8sjc-0})
+    (sealed #t))
+
+  (define-record-type pred-$record/ref
+    (fields ref)
+    (nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0})
+    (sealed #t))
+
+  (module (pred-env-empty
+           pred-env-add pred-env-remove/base pred-env-lookup
+           pred-env-intersect/base pred-env-union/super-base
+           pred-env-rebase
+           pred-intersect pred-union)
+    (import fxmap)
+
+    (define pred-env-empty empty-fxmap)
+
+    (define (pred-env-add/key types key pred)
+      (cond
+        [(and pred
+              (not (eq? pred 'ptr))) ; filter 'ptr to reduce the size
+         (let ([old (fxmap-ref types key #f)])
+           (cond
+             [(not old)
+              (fxmap-set types key pred)]
+             [else (let ([new (pred-intersect old pred)])
+                     (if (eq? old new)
+                         types
+                        (fxmap-set types key new)))]))]
+        [else
+         types]))
+
+    (define (pred-env-add types x pred)
+      (cond
+        [(and x (not (prelex-assigned x)))
+         (pred-env-add/key types (prelex-counter x) pred)]
+        [else types]))
+
+    (define (pred-env-remove/base types x base)
+      (fxmap-remove/base types (prelex-counter x) base))
+
+    (define (pred-env-lookup types x)
+      (and (not (prelex-assigned x))
+           (fxmap-ref types (prelex-counter x) #f)))
+
+    ; This is conceptually the intersection of the types in `types` and `from`
+    ; but since 'ptr is not stored to save space and time, the implementation
+    ; looks like an union of the fxmaps.
+    ; [missing 'ptr] _and_ 'vector -> 'vector
+    ; 'box _and_ 'vector -> 'bottom
+    ; 'number _and_ 'exact-integer -> 'exact-integer
+    (define (pred-env-intersect/base types from base)
+      (cond
+        [(fx> (fxmap-changes from) (fxmap-changes types))
+         (pred-env-intersect/base from types base)]
+        [else
+        (let ([ret types])
+          (fxmap-for-each/diff (lambda (key x y)
+                                 (let ([z (fxmap-ref types key #f)])
+                                   ;x-> from
+                                   ;y-> base
+                                   ;z-> types
+                                   (set! ret (pred-env-add/key ret key (pred-intersect x z)))))
+                               (lambda (key x)
+                                 (set! ret (pred-env-add/key ret key x)))
+                               (lambda (key x)
+                                 ($impoops 'pred-env-intersect/base "unexpected value ~s in base environment ~s" x base))
+                               from
+                               base)
+           ret)]))
+
+    (define (pred-intersect x y)
+      (cond
+        [(predicate-implies? x y) x]
+        [(predicate-implies? y x) y]
+        [(or (predicate-implies-not? x y)
+             (predicate-implies-not? y x))
+         'bottom]
+        [(or (and (eq? x 'boolean) (eq? y 'true))
+             (and (eq? y 'boolean) (eq? x 'true)))
+         true-rec]
+        [else (or x y)])) ; if there is no exact option, at least keep the old value
+
+    ; This is conceptually the union of the types in `types` and `from`
+    ; but since 'ptr is not stored to save space and time, the implementation
+    ; looks like an intersection of the fxmaps.
+    ; [missing 'ptr] _or_ 'vector -> [missing 'ptr]
+    ; 'box _or_ 'boolean -> [missing 'ptr]
+    ; 'number _or_ 'exact-integer -> 'number
+    (define (pred-env-union/from from base types new-base)
+      ; Calculate the union of types and from, and intersect it with new-base
+      ; Iterate over the difference of from and base.
+      (let ([ret new-base])
+        (fxmap-for-each/diff (lambda (key x y)
+                               (let ([z (fxmap-ref types key #f)])
+                                 ;x-> from
+                                 ;y-> base
+                                 ;z-> types
+                                 (set! ret (pred-env-add/key ret key (pred-union x z)))))
+                             (lambda (key x)
+                               (let ([z (fxmap-ref types key #f)])
+                                 ;x-> from
+                                 ;z-> types
+                                 (set! ret (pred-env-add/key ret key (pred-union x z)))))
+                             (lambda (key x)
+                               ($impoops 'pred-env-union/from "unexpected value ~s in base environment ~s" x base))
+                             from
+                             base)
+          ret))
+
+    (define (pred-env-union/super-base types types/b
+                                       from from/b
+                                       base
+                                       new-base)
+      ; Calculate the union of types and from, and intersect it with new-base
+      ; Use the intermediate bases to minimize the amount of operations
+      ; required. In particular, base should be the base of types/b and from/b.
+      (let ([size-types (fx- (fxmap-changes types) (fxmap-changes base))]
+            [size-from (fx- (fxmap-changes from) (fxmap-changes base))]
+            [size-new (fx+ (fx- (fxmap-changes types) (fxmap-changes types/b))
+                           (fx- (fxmap-changes from) (fxmap-changes from/b)))])
+        (cond
+          [(and (fx<= size-types size-from) (fx<= size-types size-new))
+           (pred-env-union/from types base from new-base)]
+          [(fx<= size-from size-new)
+           (pred-env-union/from from base types new-base)]
+          [else
+           (let ([temp (pred-env-union/from from from/b types new-base)])
+             (pred-env-union/from types types/b from temp))])))
+
+    (define (pred-union x y)
+      (cond
+        [(predicate-implies? y x) x]
+        [(predicate-implies? x y) y]
+        [(find (lambda (t)
+                 (and (predicate-implies? x t)
+                      (predicate-implies? y t)))
+               '(char null-or-pair $record
+                 gensym symbol
+                 fixnum exact-integer flonum real number
+                 boolean true ptr))] ; ensure they are order from more restrictive to less restrictive
+        [else #f]))
+
+    (define (pred-env-rebase types base new-base)
+      (let ([ret types])
+        (fxmap-for-each/diff (lambda (key x y)
+                               (let ([z (fxmap-ref types key #f)])
+                                 ;x-> new-base
+                                 ;y-> base
+                                 ;z-> types
+                                 (if (eq? x z)
+                                     (set! ret (fxmap-reset/base ret key new-base))
+                                     (set! ret (fxmap-advance/base ret key new-base)))))
+                             (lambda (key x)
+                               (let ([z (fxmap-ref types key #f)])
+                                 ;x-> new-base
+                                 ;z-> types
+                                 (if (eq? x z)
+                                     (set! ret (fxmap-reset/base ret key new-base))
+                                     (set! ret (fxmap-advance/base ret key new-base)))))
+                             (lambda (key x)
+                               ($impoops 'pred-env-rebase "unexpected value ~s in base environment ~s" x base))
+                             new-base
+                             base)
+        ret))
+ )
+
+  (define (pred-env-add/ref types r pred)
+    (nanopass-case (Lsrc Expr) r
+      [(ref ,maybe-src ,x)
+       (pred-env-add types x pred)]
+      [else types]))
+
+  ;copied from cp0.ss
+  (define (arity-okay? arity n)
+    (or (not arity) ; presumably system routine w/no recorded arity
+        (ormap
+          (lambda (a)
+            (or (fx= n a)
+                (and (fx< a 0) (fx>= n (fx- -1 a)))))
+          arity)))
+
+  ;copied from cp0.ss
+  (define okay-to-copy?
+    (lambda (obj)
+      ; okay to copy obj if (eq? (faslin (faslout x)) x) => #t or (in the case of numbers and characters)
+      ; the value of (eq? x x) is unspecified
+      (or (symbol? obj)
+          (number? obj)
+          (char? obj)
+          (boolean? obj)
+          (null? obj)
+          (eqv? obj "")
+          (eqv? obj '#())
+          (eqv? obj '#vu8())
+          (eqv? obj '#vfx())
+          (eq? obj (void))
+          (eof-object? obj)
+          (bwp-object? obj)
+          (eq? obj '#6=#6#)
+          ($unbound-object? obj)
+          (record-type-descriptor? obj)))) ;removed in datum->predicate
+
+  (define (datum->predicate d ir)
+    (cond
+      [(#3%$record? d) '$record] ;check first to avoid double representation of rtd
+      [(okay-to-copy? d) ir]
+      [(and (integer? d) (exact? d)) 'exact-integer]
+      [(pair? d) 'pair]
+      [(box? d) 'box]
+      [(vector? d) 'vector]
+      [(string? d) 'string]
+      [(bytevector? d) 'bytevector]
+      [(fxvector? d) 'fxvector]
+      [else #f]))
+
+  (define (rtd->record-predicate rtd)
+    (cond
+      [(Lsrc? rtd)
+       (nanopass-case (Lsrc Expr) rtd
+         [(quote ,d)
+          (guard (record-type-descriptor? d))
+          (make-pred-$record/rtd d)]
+         [(ref ,maybe-src ,x)
+          (guard (not (prelex-assigned x)))
+          (make-pred-$record/ref x)]
+         [(record-type ,rtd ,e)
+          (rtd->record-predicate e)]
+         [else '$record])]
+      [else '$record]))
+
+  ; when extend is #f the result is a predicate that recognizes less values
+  ; than the one in name. This is useful for reductions like
+  ; (pred? x) ==> #t and (something x) ==> (#3%something x)
+  ; when extend is #t the result is a predicate that recognizes more values
+  ; than the one in name. This is useful for reductions like
+  ; (pred? x) ==> #f and (something x) ==> <error>
+  ; in case the non extended version is not #f, the extended version must be not #f
+  (define (primref-name->predicate name extend?)
+    (case name
+      [pair? 'pair]
+      [box? 'box]
+      [$record? '$record]
+      [fixnum? 'fixnum]
+      [flonum? 'flonum]
+      [real? 'real]
+      [number? 'number]
+      [vector? 'vector]
+      [string? 'string]
+      [bytevector? 'bytevector]
+      [fxvector? 'fxvector]
+      [gensym? 'gensym]
+      [symbol? 'symbol]
+      [char? 'char]
+      [boolean? 'boolean]
+      [procedure? 'procedure]
+      [not false-rec]
+      [null? null-rec]
+      [eof-object? eof-rec]
+      [bwp-object? bwp-rec]
+      [list? (if (not extend?) null-rec 'null-or-pair)]
+      [else ((if extend? cdr car)
+             (case name
+               [(record? record-type-descriptor?) '(bottom . $record)]
+               [(integer? rational?) '(exact-integer . real)]
+               [(cflonum?) '(flonum . number)]
+               [else '(#f . #f)]))])) ; this is used only to detect predicates.
+
+  ; nqm: no question mark
+  ; this is almost duplicated code, but with more cases
+  ; it's also useful to avoid the allocation
+  ; of the temporal strings to transform: vector -> vector?
+  (define (primref-name/nqm->predicate name extend?)
+    (case name
+      [pair 'pair]
+      [box 'box]
+      [$record '$record]
+      [fixnum 'fixnum]
+      [flonum 'flonum]
+      [real 'real]
+      [number 'number]
+      [vector 'vector]
+      [string 'string]
+      [bytevector 'bytevector]
+      [fxvector 'fxvector]
+      [gensym 'gensym]
+      [symbol 'symbol]
+      [char 'char]
+      [bottom 'bottom] ;pseudo-predicate
+      [ptr 'ptr] ;pseudo-predicate
+      [boolean 'boolean]
+      [procedure 'procedure]
+      [exact-integer 'exact-integer] ;fake-predicate
+      [void void-rec] ;fake-predicate
+      [null null-rec]
+      [eof-object eof-rec]
+      [bwp-object bwp-rec]
+      [list (if (not extend?) null-rec 'null-or-pair)] ;fake-predicate
+      [else ((if extend? cdr car)
+             (case name
+               [(record rtd) '(bottom . $record)]
+               [(bit length ufixnum pfixnum) '(bottom . fixnum)]
+               [(uint sub-uint) '(bottom . exact-integer)]
+               [(sint) '(fixnum . exact-integer)]
+               [(uinteger) '(bottom . real)]
+               [(integer rational) '(exact-integer . real)]
+               [(cflonum) '(flonum . number)]
+               [else '(bottom . ptr)]))])) ; this is used only to analyze the signatures.
+
+  (define (primref->predicate pr extend?)
+    (primref-name->predicate (primref-name pr) extend?))
+
+  (define (check-constant-is? x pred?)
+    (nanopass-case (Lsrc Expr) x
+      [(quote ,d) (pred? d)]
+      [else #f]))
+
+  ; strange properties of bottom here:
+  ; (implies? x bottom): only for x=bottom
+  ; (implies? bottom y): always
+  ; (implies-not? x bottom): never
+  ; (implies-not? bottom y): never
+  ; check (implies? x bottom) before (implies? x something)
+  (define (predicate-implies? x y)
+    (and x
+         y
+         (or (eq? x y)
+             (eq? x 'bottom)
+             (cond
+               [(Lsrc? y)
+                (and (Lsrc? x)
+                     (nanopass-case (Lsrc Expr) y
+                       [(quote ,d1)
+                        (nanopass-case (Lsrc Expr) x
+                          [(quote ,d2) (eqv? d1 d2)]
+                          [else #f])]
+                       [else #f]))]
+               [(pred-$record/rtd? y)
+                (and (pred-$record/rtd? x)
+                     (let ([x-rtd (pred-$record/rtd-rtd x)]
+                           [y-rtd (pred-$record/rtd-rtd y)])
+                       (cond
+                         [(record-type-sealed? y-rtd)
+                          (eqv? x-rtd y-rtd)]
+                         [else
+                          (let loop ([x-rtd x-rtd])
+                            (or (eqv? x-rtd y-rtd)
+                                (let ([xp-rtd (record-type-parent x-rtd)])
+                                  (and xp-rtd (loop xp-rtd)))))])))]
+               [(pred-$record/ref? y)
+                (and (pred-$record/ref? x)
+                     (eq? (pred-$record/ref-ref x)
+                          (pred-$record/ref-ref y)))]
+               [(case y
+                  [(null-or-pair) (or (eq? x 'pair)
+                                      (check-constant-is? x null?))]
+                  [(fixnum) (check-constant-is? x target-fixnum?)]
+                  [(exact-integer)
+                   (or (eq? x 'fixnum)
+                       (check-constant-is? x (lambda (x) (and (integer? x)
+                                                              (exact? x)))))]
+                  [(flonum) (check-constant-is? x flonum?)]
+                  [(real) (or (eq? x 'fixnum)
+                              (eq? x 'exact-integer)
+                              (eq? x 'flonum)
+                              (check-constant-is? x real?))]
+                  [(number) (or (eq? x 'fixnum)
+                                (eq? x 'exact-integer)
+                                (eq? x 'flonum)
+                                (eq? x 'real)
+                                (check-constant-is? x number?))]
+                  [(gensym) (check-constant-is? x gensym?)]
+                  [(symbol) (or (eq? x 'gensym)
+                                (check-constant-is? x symbol?))]
+                  [(char) (check-constant-is? x char?)]
+                  [(boolean) (check-constant-is? x boolean?)]
+                  [(true) (and (not (check-constant-is? x not))
+                               (not (eq? x 'boolean))
+                               (not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f
+                  [($record) (or (pred-$record/rtd? x)
+                                 (pred-$record/ref? x)
+                                 (check-constant-is? x #3%$record?))]
+                  [(vector) (check-constant-is? x vector?)] ; i.e. '#()
+                  [(string) (check-constant-is? x string?)] ; i.e. ""
+                  [(bytevector) (check-constant-is? x bytevector?)] ; i.e. '#vu8()
+                  [(fxvector) (check-constant-is? x fxvector?)] ; i.e. '#vfx()
+                  [(ptr) #t]
+                  [else #f])]
+               [else #f]))))
+
+  (define (predicate-implies-not? x y)
+    (and x
+         y
+         ; a pred-$record/ref may be any other kind or record
+         (not (and (pred-$record/ref? x)
+                   (predicate-implies? y '$record)))
+         (not (and (pred-$record/ref? y)
+                   (predicate-implies? x '$record)))
+         ; boolean and true may be a #t
+         (not (and (eq? x 'boolean)
+                   (eq? y 'true)))
+         (not (and (eq? y 'boolean)
+                   (eq? x 'true)))
+         ; the other types are included or disjoint
+         (not (predicate-implies? x y))
+         (not (predicate-implies? y x))))
+
+  (define (signature->result-predicate signature)
+    (let ([results (cdr signature)])
+      (and (fx= (length results) 1)
+           (let ([result (car results)])
+             (cond
+               [(symbol? result)
+                (primref-name/nqm->predicate result #t)]
+               [(equal? result '(ptr . ptr))
+                'pair]
+               [(pair? result)
+                'pair]
+               [else
+                'ptr])))))
+
+  (define primref->result-predicate/cache (make-hashtable equal-hash equal?))
+
+  (define (primref->result-predicate pr)
+    (let ([key (primref-name pr)])
+      (if (hashtable-contains? primref->result-predicate/cache key)
+          (hashtable-ref primref->result-predicate/cache key #f)
+          (let ([new (primref->result-predicate/no-cache pr)])
+            (hashtable-set! primref->result-predicate/cache key new)
+            new))))
+
+  (define (primref->result-predicate/no-cache pr)
+    (let ([pred/flags
+           (let ([flags (primref-flags pr)])
+             (cond
+               [(all-set? (prim-mask abort-op) flags)
+                'bottom]
+               [(all-set? (prim-mask true) flags)
+                'true]
+               [(all-set? (prim-mask boolean-valued) flags)
+                'boolean]
+               [else
+                #f]))]
+          [pred/signatures
+           (let ([signatures (primref-signatures pr)])
+             (and (not (null? signatures))
+                  (let ([results (map (lambda (s) (signature->result-predicate s)) signatures)])
+                    (fold-left pred-union 'bottom results))))])
+      (pred-intersect pred/flags pred/signatures)))
+
+  (define (signature->argument-predicate signature pos extend?)
+    (let* ([arguments (car signature)]
+           [dots (memq '... arguments)])
+      (cond
+        [(and dots (null? (cdr dots)))
+         (cond
+           [(< pos (- (length arguments) 2))
+            (primref-name/nqm->predicate (list-ref arguments pos) extend?)]
+           [else
+            (primref-name/nqm->predicate (list-ref arguments (- (length arguments) 2)) extend?)])]
+         [dots #f] ; TODO: Extend to handle this case, perhaps knowing the argument count.
+         [else
+          (cond
+            [(< pos (length arguments))
+             (let ([argument (list-ref arguments pos)])
+               (cond
+                 [(equal? argument '(ptr . ptr))
+                  'pair]
+                 [(and extend? (pair? argument))
+                  'pair]
+                 [else
+                  (primref-name/nqm->predicate argument extend?)]))]
+            [else
+             'bottom])])))
+
+  (define primref->argument-predicate/cache (make-hashtable equal-hash equal?))
+
+  (define (primref->argument-predicate pr pos extend?)
+    (let ([key (list (primref-name pr) pos extend?)])
+      (if (hashtable-contains? primref->argument-predicate/cache key)
+          (hashtable-ref primref->argument-predicate/cache key #f)
+          (let ([new (primref->argument-predicate/no-cache pr pos extend?)])
+            (when (<= pos 10)
+              (hashtable-set! primref->argument-predicate/cache key new))
+            new))))
+
+  (define (primref->argument-predicate/no-cache pr pos extend?)
+    (let ([signatures (primref-signatures pr)])
+      (and (>= (length signatures) 1)
+           (let ([vals (map (lambda (signature)
+                              (signature->argument-predicate signature pos extend?))
+                            signatures)])
+             (fold-left (if extend? pred-union pred-intersect) (car vals) (cdr vals))))))
+
+  (define (primref->unsafe-primref pr)
+    (lookup-primref 3 (primref-name pr)))
+)
+    (Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types)
+      [(quote ,d)
+       (values ir (datum->predicate d ir) types #f #f)]
+      [(ref ,maybe-src ,x)
+       (case ctxt
+         [(test)
+          (let ([t (pred-env-lookup types x)])
+            (cond
+              [(predicate-implies-not? t false-rec)
+               (values true-rec true-rec types #f #f)]
+              [(predicate-implies? t false-rec)
+               (values false-rec false-rec types #f #f)]
+              [else
+               (values ir t
+                      types
+                      (pred-env-add/ref types ir 'true) ; don't confuse it with true-rec
+                      (pred-env-add/ref types ir false-rec))]))]
+         [else
+           (let ([t (pred-env-lookup types x)])
+            (cond
+              [(Lsrc? t)
+               (nanopass-case (Lsrc Expr) t
+                 [(quote ,d)
+                  (values t t types #f #f)]
+                 [else
+                  (values ir t types #f #f)])]
+               [else
+                (values ir t types #f #f)]))])]
+      [(seq ,[e1 'effect types -> e1 ret1 types t-types f-types] ,e2)
+       (cond
+         [(predicate-implies? ret1 'bottom)
+          (values e1 ret1 types #f #f)]
+         [else
+          (let-values ([(e2 ret types t-types f-types)
+                        (Expr e2 ctxt types)])
+            (values (make-seq ctxt e1 e2) ret types t-types f-types))])]
+      [(if ,[e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3)
+       (cond
+         [(predicate-implies? ret1 'bottom) ;check bottom first
+          (values e1 ret1 types #f #f)]
+         [(predicate-implies-not? ret1 false-rec)
+          (let-values ([(e2 ret types t-types f-types)
+                        (Expr e2 ctxt types1)])
+            (values (make-seq ctxt e1 e2) ret types t-types f-types))]
+         [(predicate-implies? ret1 false-rec)
+          (let-values ([(e3 ret types t-types f-types)
+                        (Expr e3 ctxt types1)])
+            (values (make-seq ctxt e1 e3) ret types t-types f-types))]
+         [else
+          (let*-values ([(t-types1) (or t-types1 types1)]
+                        [(f-types1) (or f-types1 types1)]
+                        [(e2 ret2 types2 t-types2 f-types2)
+                         (Expr e2 ctxt t-types1)]
+                        [(t-types2) (or t-types2 types2)]
+                        [(f-types2) (or f-types2 types2)]
+                        [(e3 ret3 types3 t-types3 f-types3)
+                         (Expr e3 ctxt f-types1)]
+                        [(t-types3) (or t-types3 types3)]
+                        [(f-types3) (or f-types3 types3)])
+            (let ([ir `(if ,e1 ,e2 ,e3)])
+              (cond
+                [(predicate-implies? ret2 'bottom) ;check bottom first
+                 (values ir ret3 types3 t-types3 f-types3)]
+                [(predicate-implies? ret3 'bottom) ;check bottom first
+                 (values ir ret2 types2 t-types2 f-types2)]
+                [else
+                 (let ([new-types (pred-env-union/super-base types2 t-types1
+                                                             types3 f-types1
+                                                             types1
+                                                             types1)])
+                   (values ir
+                           (cond
+                             [(and (eq? ctxt 'test)
+                                   (predicate-implies-not? ret2 false-rec)
+                                   (predicate-implies-not? ret3 false-rec))
+                              true-rec]
+                             [else
+                              (pred-union ret2 ret3)])
+                           new-types
+                           (cond
+                             [(not (eq? ctxt 'test))
+                              #f] ; don't calculate t-types outside a test context
+                             [(predicate-implies? ret2 false-rec)
+                              (pred-env-rebase t-types3 types1 new-types)]
+                             [(predicate-implies? ret3 false-rec)
+                              (pred-env-rebase t-types2 types1 new-types)]
+                             [(and (eq? types2 t-types2)
+                                   (eq? types3 t-types3))
+                              #f] ; don't calculate t-types when it will be equal to new-types
+                             [else
+                              (pred-env-union/super-base t-types2 t-types1
+                                                         t-types3 f-types1
+                                                         types1
+                                                         new-types)])
+                           (cond
+                             [(not (eq? ctxt 'test))
+                              #f] ; don't calculate f-types outside a test context
+                             [(predicate-implies-not? ret2 false-rec)
+                              (pred-env-rebase f-types3 types1 new-types)]
+                             [(predicate-implies-not? ret3 false-rec)
+                              (pred-env-rebase f-types2 types1 new-types)]
+                             [(and (eq? types2 f-types2)
+                                   (eq? types3 f-types3))
+                              #f] ; don't calculate t-types when it will be equal to new-types
+                             [else
+                              (pred-env-union/super-base f-types2 t-types1
+                                                         f-types3 f-types1
+                                                         types1
+                                                         new-types)])))])))])]
+      [(set! ,maybe-src ,x ,[e 'value types -> e ret types t-types f-types])
+       (values `(set! ,maybe-src ,x ,e) void-rec types #f #f)]
+      [(call ,preinfo ,pr ,[e* 'value types -> e* r* t* t-t* f-t*] ...)
+       (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
+              [ret (primref->result-predicate pr)])
+         (let-values ([(ret t)
+                       (let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t])
+                         (if (null? e*)
+                             (values ret t)
+                             (let ([pred (primref->argument-predicate pr n #t)])
+                               (loop (cdr e*)
+                                     (cdr r*)
+                                     (fx+ n 1)
+                                     (if (predicate-implies-not? (car r*) pred)
+                                         'bottom
+                                         ret)
+                                     (pred-env-add/ref t (car e*) pred)))))])
+           (cond
+             [(predicate-implies? ret 'bottom)
+              (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)]
+             [(not (arity-okay? (primref-arity pr) (length e*)))
+              (values `(call ,preinfo ,pr ,e* ...) 'bottom t #f #f)]
+             [(and (fx= (length e*) 2)
+                   (or (eq? (primref-name pr) 'eq?)
+                       (eq? (primref-name pr) 'eqv?)))
+                (let ([r1 (car r*)]
+                      [r2 (cadr r*)]
+                      [e1 (car e*)]
+                      [e2 (cadr e*)])
+                  (cond
+                    [(or (predicate-implies-not? r1 r2)
+                         (predicate-implies-not? r2 r1))
+                     (values (make-seq ctxt (make-seq 'effect e1 e2) false-rec)
+                             false-rec t #f #f)]
+                    [else
+                     (values `(call ,preinfo ,pr ,e* ...)
+                             ret
+                             types
+                             (and (eq? ctxt 'test)
+                                  (pred-env-add/ref
+                                   (pred-env-add/ref t e1 r2)
+                                   e2 r1))
+                             #f)]))]
+             [(and (fx= (length e*) 1)
+                   (primref->predicate pr #t))
+              (let ([var (car r*)]
+                    [pred (primref->predicate pr #f)])
+                (cond
+                    [(predicate-implies? var pred)
+                     (values (make-seq ctxt (car e*) true-rec)
+                             true-rec t #f #f)]
+                    [else
+                     (let ([pred (primref->predicate pr #t)])
+                       (cond
+                         [(predicate-implies-not? var pred)
+                          (values (make-seq ctxt (car e*) false-rec)
+                                  false-rec t #f #f)]
+                         [else
+                          (values `(call ,preinfo ,pr ,e* ...)
+                                  ret
+                                  types
+                                  (and (eq? ctxt 'test)
+                                       (pred-env-add/ref t (car e*) pred))
+                                  #f)]))]))]
+             [(and (fx>= (length e*) 1)
+                   (eq? (primref-name pr) '$record))
+              (values `(call ,preinfo ,pr ,e* ...) (rtd->record-predicate (car e*)) t #f #f)]
+             [(and (fx= (length e*) 2)
+                   (or (eq? (primref-name pr) 'record?)
+                       (eq? (primref-name pr) '$sealed-record?)))
+              (let ([pred (rtd->record-predicate (cadr e*))]
+                    [var (car r*)])
+                (cond
+                  [(predicate-implies-not? var pred)
+                   (cond
+                     [(or (all-set? (prim-mask unsafe) (primref-flags pr))
+                          (nanopass-case (Lsrc Expr) (cadr e*) ; ensure that it is actually a rtd
+                            [(quote ,d)
+                             (record-type-descriptor? d)]
+                            [(record-type ,rtd ,e) #t]
+                            [else #f]))
+                      (values (make-seq ctxt (make-seq 'effect (car e*) (cadr e*)) false-rec)
+                              false-rec t #f #f)]
+                     [else
+                      (values (make-seq ctxt ir false-rec)
+                              false-rec t #f #f)])]
+                  [(and (not (eq? pred '$record)) ; assume that the only extension is '$record
+                        (predicate-implies? var pred))
+                   (values (make-seq ctxt (make-seq 'effect (car e*) (cadr e*)) true-rec)
+                           true-rec t #f #f)]
+                  [(and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
+                        (nanopass-case (Lsrc Expr) (cadr e*) ; check that it is a rtd
+                          [(quote ,d)
+                           (record-type-descriptor? d)]
+                          [(record-type ,rtd ,e) #t]
+                          [else #f]))
+                   (let ([pr (primref->unsafe-primref pr)])
+                     (values `(call ,preinfo ,pr ,e* ...)
+                             ret types
+                             (and (eq? ctxt 'test)
+                                  (pred-env-add/ref types (car e*) pred))
+                             #f))]
+                  [else
+                   (values `(call ,preinfo ,pr ,e* ...)
+                           ret
+                           types
+                           (and (eq? ctxt 'test)
+                                (pred-env-add/ref types (car e*) pred))
+                           #f)]))]
+             ; TODO: special case for call-with-values.
+             [(eq? (primref-name pr) 'list)
+              (cond 
+                [(null? e*)
+                 ;should have be reduced by cp0
+                 (values null-rec null-rec t #f #f)]
+                [else
+                 (values `(call ,preinfo ,pr ,e* ...) 'pair t #f #f)])]
+             [(and (fx= (length e*) 1)
+                   (eq? (primref-name pr) 'exact?))
+              (cond
+                [(predicate-implies? (car r*) 'exact-integer)
+                 (values (make-seq ctxt (car e*) true-rec)
+                         true-rec t #f #f)]
+                [(predicate-implies? (car r*) 'flonum)
+                 (values (make-seq ctxt (car e*) false-rec)
+                         false-rec t #f #f)]
+                [(and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
+                      (predicate-implies? (car r*) 'number))
+                 (let ([pr (primref->unsafe-primref pr)])
+                   (values `(call ,preinfo ,pr ,e* ...)
+                           ret t #f #f))]
+                [else
+                 (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])]
+             [(and (fx= (length e*) 1)
+                   (eq? (primref-name pr) 'inexact?))
+              (cond
+                [(predicate-implies? (car r*) 'exact-integer)
+                 (values (make-seq ctxt (car e*) false-rec)
+                         false-rec t #f #f)]
+                [(predicate-implies? (car r*) 'flonum)
+                 (values (make-seq ctxt (car e*) true-rec)
+                         true-rec t #f #f)]
+                [(and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
+                      (predicate-implies? (car r*) 'number))
+                 (let ([pr (primref->unsafe-primref pr)])
+                   (values `(call ,preinfo ,pr ,e* ...)
+                           ret t #f #f))]
+                [else
+                 (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])]
+             [(and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
+                   (all-set? (prim-mask safeongoodargs) (primref-flags pr))
+                   (andmap (lambda (r n)
+                             (predicate-implies? r
+                                                 (primref->argument-predicate pr n #f)))
+                           r* (enumerate r*)))
+               (let ([pr (primref->unsafe-primref pr)])
+                 (values `(call ,preinfo ,pr ,e* ...)
+                         ret types #f #f))]
+             [else
+              (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])))]
+      [(case-lambda ,preinfo ,cl* ...)
+       (let ([cl* (map (lambda (cl)
+                        (nanopass-case (Lsrc CaseLambdaClause) cl
+                          [(clause (,x* ...) ,interface ,body)
+                           (let-values ([(body ret types t-types f-types)
+                                         (Expr body 'value types)])
+                             (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
+                             (with-output-language (Lsrc CaseLambdaClause)
+                               `(clause (,x* ...) ,interface ,body)))]))
+                       cl*)])
+         (values `(case-lambda ,preinfo ,cl* ...) 'procedure types #f #f))]
+      [(call ,preinfo (case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...)
+             ,[e* 'value types -> e* r* t* t-t* f-t*] ...)
+       ;; pulled from cpnanopass
+       (define find-matching-clause
+         (lambda (len x** interface* body* kfixed kvariable kfail)
+           (let f ([x** x**] [interface* interface*] [body* body*])
+             (if (null? interface*)
+                 (kfail)
+                 (let ([interface (car interface*)])
+                   (if (fx< interface 0)
+                       (let ([nfixed (fxlognot interface)])
+                         (if (fx>= len nfixed)
+                             (kvariable nfixed (car x**) (car body*))
+                             (f (cdr x**) (cdr interface*) (cdr body*))))
+                       (if (fx= interface len)
+                           (kfixed (car x**) (car body*))
+                           (f (cdr x**) (cdr interface*) (cdr body*)))))))))
+       (define finish
+         (lambda (x* interface body t)
+           (let-values ([(body ret n-types t-types f-types)
+                         (Expr body ctxt t)])
+             (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
+                    [t-types (and (eq? ctxt 'test)
+                                  t-types
+                                  (not (eq? n-types t-types))
+                                  (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
+                    [f-types (and (eq? ctxt 'test)
+                                  f-types
+                                  (not (eq? n-types f-types))
+                                  (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
+               (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
+               (values
+                 `(call ,preinfo (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...)
+                 ret new-types t-types f-types)))))
+       (let ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
+             [len (length e*)])
+         (find-matching-clause (length e*) x** interface* body*
+           (lambda (x* body) (finish x* len body (fold-left pred-env-add t x* r*)))
+           (lambda (nfixed x* body)
+             (finish x* (fxlognot nfixed) body
+               (fold-left pred-env-add t x*
+                 (let f ([i nfixed] [r* r*])
+                   (if (fx= i 0)
+                       (list (if (null? r*) null-rec 'pair))
+                       (cons (car r*) (f (fx- i 1) (cdr r*))))))))
+           (lambda () (values ir 'bottom types #f #f))))]
+      [(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0]
+             ,[e* 'value types -> e* r* t* t-t* f-t*]  ...)
+       (values `(call ,preinfo ,e0 ,e* ...)
+               #f
+               (pred-env-add/ref
+                 (pred-env-intersect/base
+                   (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
+                   types0 types)
+                 e0 'procedure)
+               #f #f)]
+      [(letrec ((,x* ,[e* 'value types -> e* r* t* t-t* t-f*]) ...) ,body)
+       (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
+              [t (fold-left pred-env-add t x* r*)])
+        (let-values ([(body ret n-types t-types f-types)
+                      (Expr body ctxt t)])
+          (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
+                 [t-types (and (eq? ctxt 'test)
+                               t-types
+                               (not (eq? n-types t-types))
+                               (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
+                 [f-types (and (eq? ctxt 'test)
+                               f-types
+                               (not (eq? n-types f-types))
+                               (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
+            (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
+            (values `(letrec ([,x* ,e*] ...) ,body)
+                    ret new-types t-types f-types))))]
+      [(letrec* ((,x* ,e*) ...) ,body)
+       (let*-values ([(e* types)
+                      (let loop ([x* x*] [e* e*] [types types] [rev-e* '()]) ; this is similar to an ordered-map
+                        (if (null? x*)
+                          (values (reverse rev-e*) types)
+                          (let-values ([(e ret types t-types f-types)
+                                        (Expr (car e*) 'value types)])
+                            (let ([types (pred-env-add types (car x*) ret)])
+                              (loop (cdr x*) (cdr e*) types (cons e rev-e*))))))])
+        (let-values ([(body ret n-types t-types f-types)
+                      (Expr body ctxt types)])
+          (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
+                 [t-types (and (eq? ctxt 'test)
+                               t-types
+                               (not (eq? n-types t-types))
+                               (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
+                 [f-types (and (eq? ctxt 'test)
+                               f-types
+                               (not (eq? n-types f-types))
+                               (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
+            (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
+            (values `(letrec* ([,x* ,e*] ...) ,body)
+                    ret new-types t-types f-types))))]
+      [,pr
+       (values ir
+               (and (all-set? (prim-mask proc) (primref-flags pr)) 'procedure)
+               types #f #f)]
+      [(foreign (,conv* ...) ,name ,[e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type)
+       (values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
+               #f types #f #f)]
+      [(fcallable (,conv* ...) ,[e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type)
+       (values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
+               #f types #f #f)]
+      [(record ,rtd ,[rtd-expr 'value types -> rtd-expr ret-re types-re t-types-re f-types-re]
+               ,[e* 'value types -> e* r* t* t-t* f-t*] ...)
+       (values `(record ,rtd ,rtd-expr ,e* ...)
+               (rtd->record-predicate rtd-expr)
+               (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
+               #f #f)]
+      [(record-ref ,rtd ,type ,index ,[e 'value types -> e ret types t-types f-types])
+       (values `(record-ref ,rtd ,type ,index ,e)
+               #f
+               (pred-env-add/ref types e '$record)
+               #f #f)]
+      [(record-set! ,rtd ,type ,index ,[e1 'value types -> e1 ret1 types1 t-types1 f-types1]
+                    ,[e2 'value types -> e2 ret2 types2 t-types2 f-types2])
+       (values `(record-set! ,rtd ,type ,index ,e1 ,e2)
+               void-rec
+               (pred-env-add/ref (pred-env-intersect/base types1 types2 types)
+                                 e1 '$record)
+               #f #f)]
+      [(record-type ,rtd ,[e 'value types -> e ret types t-types f-types])
+       (values `(record-type ,rtd ,e)
+               #f types #f #f)]
+      [(record-cd ,rcd ,rtd-expr ,[e 'value types -> e ret types t-types f-types])
+       (values `(record-cd ,rcd ,rtd-expr ,e)
+               #f types #f #f)]
+      [(immutable-list (,[e* 'value types -> e* r* t* t-t* f-t*] ...)
+                       ,[e 'value types -> e ret types t-types f-types])
+       (values `(immutable-list (,e*  ...) ,e)
+               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)
+               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)]
+      [else ($oops who "unrecognized record ~s" ir)])
+    (let-values ([(ir ret types t-types f-types)
+                  (Expr ir 'value pred-env-empty)])
+      ir))
+
+  (set! $cptypes cptypes)
+
+)
diff --git a/s/front.ss b/s/front.ss
index 5a2bb670e7..a46276d709 100644
--- a/s/front.ss
+++ b/s/front.ss
@@ -104,6 +104,7 @@
 
 (define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
 
+
 (define-who current-generate-id
   ($make-thread-parameter
    (lambda (sym)
@@ -113,6 +114,9 @@
      (unless (procedure? p) ($oops who "~s is not a procedure" p))
      p)))
 
+(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
+
+
 (define machine-type
   (lambda ()
     (constant machine-type-name)))
@@ -223,6 +227,7 @@
 (package-stubs compiler-support
   $cp0
   $cpvalid
+  $cptypes
   $cpletrec
   $cpcheck)
 (package-stubs syntax-support
diff --git a/s/fxmap.ss b/s/fxmap.ss
new file mode 100644
index 0000000000..d069a6ed37
--- /dev/null
+++ b/s/fxmap.ss
@@ -0,0 +1,490 @@
+;;; fxmap.ss
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;; Based on Okasaki and Gill's "Fast Mergeable Integer Maps" (1998).
+
+(module fxmap
+ (fxmap?
+  empty-fxmap
+  fxmap-empty?
+  fxmap-count
+  fxmap-ref
+  fxmap-set
+  fxmap-remove
+  fxmap-remove/base
+  fxmap-reset/base
+  fxmap-advance/base
+  fxmap-for-each
+  fxmap-for-each/diff
+  fxmap-changes
+
+  ;; internals
+  ; $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right
+  ; $leaf? make-$leaf $leaf-key $leaf-val
+
+  ;; We treat $empty as a singleton, so don't use these functions.
+  ; $empty? make-$empty
+  )
+
+ ;; record types
+
+ (define-record-type $branch
+   (fields prefix mask left right count changes)
+   (nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-1})
+   (sealed #t))
+
+ (define-record-type $leaf
+   (fields key val changes)
+   (nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-1})
+   (sealed #t))
+
+ (define-record-type $empty
+   (nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0})
+   (sealed #t))
+
+ (define-syntax let-branch
+   (syntax-rules ()
+     [(_ ([(p m l r) d] ...) exp ...)
+      (let ([p ($branch-prefix d)] ...
+            [m ($branch-mask d)] ...
+            [l ($branch-left d)] ...
+            [r ($branch-right d)] ...)
+        exp ...)]))
+
+ ;; constants & empty
+
+ (define empty-fxmap (make-$empty))
+
+ (define (fxmap-empty? x) (eq? empty-fxmap x))
+
+ ;; predicate
+
+ (define (fxmap? x)
+   (or ($branch? x)
+       ($leaf? x)
+       (eq? empty-fxmap x)))
+
+ ;; count & changes
+
+ (define (fxmap-count d)
+   (cond
+     [($branch? d)
+      ($branch-count d)]
+     [($leaf? d) 1]
+     [else 0]))
+
+ (define (fxmap-changes d)
+   (cond
+     [($branch? d)
+      ($branch-changes d)]
+     [($leaf? d)
+      ($leaf-changes d)]
+     [else 0]))
+
+ ;; ref
+
+ (define (fxmap-ref/leaf d key)
+   (cond
+     [($branch? d)
+      (let-branch ([(p m l r) d])
+        (cond
+          [(fx<= key p)
+           (fxmap-ref/leaf l key)]
+          [else
+           (fxmap-ref/leaf r key)]))]
+
+     [($leaf? d)
+      (if (fx= key ($leaf-key d))
+          d
+          #f)]
+
+     [else
+      #f]))
+
+ (define (fxmap-ref d key default)
+   (let ([d (fxmap-ref/leaf d key)])
+     (if d
+         ($leaf-val d)
+         default)))
+
+ (define (fxmap-ref/changes d key)
+   (let ([d (fxmap-ref/leaf d key)])
+     (if d
+         ($leaf-changes d)
+         0)))
+
+ ;; set
+
+ (define (fxmap-set/changes d key val changes)
+   (cond
+    [($branch? d)
+     (let-branch ([(p m l r) d])
+       (cond
+        [(nomatch? key p m)
+         (join key (make-$leaf key val (or changes 1)) p d)]
+        [(fx<= key p)
+         (br p m (fxmap-set/changes l key val changes) r)]
+        [else
+         (br p m l (fxmap-set/changes r key val changes))]))]
+
+    [($leaf? d)
+     (let ([k ($leaf-key d)])
+       (if (fx= key k)
+           (make-$leaf key val (or changes (fx+ ($leaf-changes d) 1)))
+           (join key (make-$leaf key val (or changes 1)) k d)))]
+
+    [else
+     (make-$leaf key val (or changes 1))]))
+
+ (define (fxmap-set d key val)
+   (fxmap-set/changes d key val #f))
+
+ ;; remove
+
+ (define (fxmap-remove d key)
+   (cond
+    [($branch? d)
+     (let-branch ([(p m l r) d])
+       (cond
+        [(nomatch? key p m) d]
+        [(fx<= key p)       (br* p m (fxmap-remove l key) r)]
+        [else               (br* p m l (fxmap-remove r key))]))]
+
+    [($leaf? d)
+     (if (fx= key ($leaf-key d))
+         empty-fxmap
+         d)]
+
+    [else
+     empty-fxmap]))
+
+ (define (fxmap-remove/base d key base)
+   ; Remove key from d, but try to reuse the branches from base when possible
+   ; instead of creating new ones.
+   ; TODO: This assumes that all the keys in base are in d too.
+   ; Perhaps this restriction can be removed.
+   (cond
+     [($branch? base)
+      (cond
+        [($branch? d)
+         (let-branch ([(p0 m0 l0 r0) base]
+                      [(p m l r) d])
+           (let ([sub-base (cond
+                             [(fx< m0 m) base]
+                             [(fx<= key p0) l0]
+                             [else r0])])
+             (cond
+               [(nomatch? key p m)
+                d]
+               [(fx<= key p)
+                (br*/base p m (fxmap-remove/base l key sub-base) r base)]
+               [else
+                (br*/base p m l (fxmap-remove/base r key sub-base) base)])))]
+
+        [($leaf? d)
+         (if (fx= key ($leaf-key d))
+             empty-fxmap
+             d)]
+
+        [else
+         empty-fxmap])]
+    [else
+     (fxmap-remove d key)]))
+
+ ;; reset and advance
+
+ (define (fxmap-reset/base d key base)
+   ; Reset key in d to the value it has in base, but try to reuse the branches
+   ; from base when possible instead of creating new ones.
+   ; TODO: This assumes that all the keys in base are in d too.
+   ; Perhaps this restriction can be removed.
+   (cond
+     [($branch? d)
+      (let-branch ([(p m l r) d])
+        (let ([sub-base (cond
+                          [($branch? base)
+                           (let-branch ([(p0 m0 l0 r0) base])
+                             (cond
+                               [(fx< m0 m) base]
+                               [(fx<= key p0) l0]
+                               [else r0]))]
+                          [else base])])
+           (cond
+             [(nomatch? key p m)
+              d]
+             [(fx<= key p)
+              (br*/base p m (fxmap-reset/base l key sub-base) r base)]
+             [else
+              (br*/base p m l (fxmap-reset/base r key sub-base) base)])))]
+
+      [(and ($leaf? d)
+            (fx= key ($leaf-key d))
+            ($leaf? base)
+            (fx= key ($leaf-key base)))
+       base]
+
+      [else
+       (error 'fxmap-reset/base "")]))
+
+ (define (fxmap-advance/base d key base)
+   (let ([changes (fx+ (fxmap-ref/changes base key) 1)]
+         [l (fxmap-ref/leaf d key)])
+     (if l
+         (if (fx= changes ($leaf-changes l))
+             d
+            (fxmap-set/changes d key ($leaf-val l) changes))
+         (error 'fxmap-advance/base ""))))
+
+ ;; set and remove utilities
+
+ (define-syntax define-syntax-rule
+  (syntax-rules ()
+    [(_ (name arg ...) e ...)
+     (define-syntax name
+       (syntax-rules ()
+         [(_ arg ...) e ...]))]))
+
+ (define (br p m l r)
+   (make-$branch p m l r
+                 (fx+ (fxmap-count l) (fxmap-count r))
+                 (fx+ (fxmap-changes l) (fxmap-changes r))))
+
+ (define (br* p m l r)
+   (cond [(eq? empty-fxmap r) l]
+         [(eq? empty-fxmap l) r]
+         [else (br p m l r)]))
+
+ (define (br*/base p m l r base)
+   (cond [(eq? empty-fxmap r) l]
+         [(eq? empty-fxmap l) r]
+         [(and ($branch? base)
+               (eq? l ($branch-left base))
+               (eq? r ($branch-right base)))
+          base]
+         [else (br p m l r)]))
+
+ (define (join p0 d0 p1 d1)
+   (let ([m (branching-bit p0 p1)])
+     (if (fx<= p0 p1)
+         (br (mask p0 m) m d0 d1)
+         (br (mask p0 m) m d1 d0))))
+
+ (define (join* p1 d1 p2 d2)
+   (cond
+     [(eq? empty-fxmap d1) d2]
+     [(eq? empty-fxmap d2) d1]
+     [else (join p1 d1 p2 d2)]))
+
+ (define (branching-bit p m)
+   (highest-set-bit (fxxor p m)))
+
+ (define-syntax-rule (mask h m)
+   (fxand (fxior h (fx1- m)) (fxnot m)))
+
+ (define highest-set-bit
+   (if (fx= (fixnum-width) 61)
+       (lambda (x1)
+         (let* ([x2 (fxior x1 (fxsrl x1 1))]
+                [x3 (fxior x2 (fxsrl x2 2))]
+                [x4 (fxior x3 (fxsrl x3 4))]
+                [x5 (fxior x4 (fxsrl x4 8))]
+                [x6 (fxior x5 (fxsrl x5 16))]
+                [x7 (fxior x6 (fxsrl x6 32))])
+           (fxxor x7 (fxsrl x7 1))))
+       (lambda (x1)
+         (let* ([x2 (fxior x1 (fxsrl x1 1))]
+                [x3 (fxior x2 (fxsrl x2 2))]
+                [x4 (fxior x3 (fxsrl x3 4))]
+                [x5 (fxior x4 (fxsrl x4 8))]
+                [x6 (fxior x5 (fxsrl x5 16))])
+           (fxxor x6 (fxsrl x6 1))))))
+
+
+ (define-syntax-rule (nomatch? h p m)
+   (not (fx= (mask h m) p)))
+
+ ;; merge
+
+ (define (fxmap-merge bin f id g1 g2 d1 d2)
+   (define-syntax go
+     (syntax-rules ()
+       [(_ d1 d2) (fxmap-merge bin f id g1 g2 d1 d2)]))
+
+   (cond
+    [(eq? d1 d2) (id d1)]
+
+    [($branch? d1)
+     (cond
+      [($branch? d2)
+       (let-branch ([(p1 m1 l1 r1) d1]
+                    [(p2 m2 l2 r2) d2])
+        (cond
+         [(fx> m1 m2) (cond
+                       [(nomatch? p2 p1 m1) (join* p1 (g1 d1) p2 (g2 d2))]
+                       [(fx<= p2 p1)        (bin p1 m1 (go l1 d2) (g1 r1))]
+                       [else                (bin p1 m1 (g1 l1) (go r1 d2))])]
+         [(fx> m2 m1) (cond
+                       [(nomatch? p1 p2 m2) (join* p1 (g1 d1) p2 (g2 d2))]
+                       [(fx<= p1 p2)        (bin p2 m2 (go d1 l2) (g2 r2))]
+                       [else                (bin p2 m2 (g2 l2) (go d1 r2))])]
+         [(fx= p1 p2) (bin p1 m1 (go l1 l2) (go r1 r2))]
+         [else        (join* p1 (g1 d1) p2 (g2 d2))]))]
+
+      [($leaf? d2)
+       (let ([k2 ($leaf-key d2)])
+         (let merge0 ([d1 d1])
+           (cond
+            [(eq? d1 d2)
+             (id d1)]
+
+            [($branch? d1)
+             (let-branch ([(p1 m1 l1 r1) d1])
+              (cond [(nomatch? k2 p1 m1) (join* p1 (g1 d1) k2 (g2 d2))]
+                    [(fx<= k2 p1)        (bin p1 m1 (merge0 l1) (g1 r1))]
+                    [else                (bin p1 m1 (g1 l1) (merge0 r1))]))]
+
+            [($leaf? d1)
+             (let ([k1 ($leaf-key d1)])
+               (cond [(fx= k1 k2) (f d1 d2)]
+                     [else        (join* k1 (g1 d1) k2 (g2 d2))]))]
+
+            [else ; (eq? empty-fxmap d1)
+             (g2 d2)])))]
+
+      [else ; (eq? empty-fxmap d2)
+       (g1 d1)])]
+
+    [($leaf? d1)
+     (let ([k1 ($leaf-key d1)])
+       (let merge0 ([d2 d2])
+         (cond
+          [(eq? d1 d2)
+           (id d1)]
+
+          [($branch? d2)
+           (let-branch ([(p2 m2 l2 r2) d2])
+            (cond [(nomatch? k1 p2 m2) (join* k1 (g1 d1) p2 (g2 d2))]
+                  [(fx<= k1 p2)        (bin p2 m2 (merge0 l2) (g2 r2))]
+                  [else                (bin p2 m2 (g2 l2) (merge0 r2))]))]
+
+          [($leaf? d2)
+           (let ([k2 ($leaf-key d2)])
+             (cond [(fx= k1 k2) (f d1 d2)]
+                   [else        (join* k1 (g1 d1) k2 (g2 d2))]))]
+
+          [else ; (eq? empty-fxmap d2)
+           (g1 d1)])))]
+
+    [else ; (eq? empty-fxmap d1)
+     (g2 d2)]))
+
+ ;; merge*
+ ; like merge, but the result is (void)
+
+ (define (fxmap-merge* f id g1 g2 d1 d2)
+   (define (merge* f id g1 g2 d1 d2)
+     (define-syntax go
+       (syntax-rules ()
+         [(_ d1 d2) (merge* f id g1 g2 d1 d2)]))
+
+     (cond
+      [(eq? d1 d2) (id d1)]
+
+      [($branch? d1)
+       (cond
+        [($branch? d2)
+         (let-branch ([(p1 m1 l1 r1) d1]
+                      [(p2 m2 l2 r2) d2])
+          (cond
+           [(fx> m1 m2) (cond
+                         [(nomatch? p2 p1 m1) (g1 d1) (g2 d2)]
+                         [(fx<= p2 p1)        (go l1 d2) (g1 r1)]
+                         [else                (g1 l1) (go r1 d2)])]
+           [(fx> m2 m1) (cond
+                         [(nomatch? p1 p2 m2) (g1 d1) (g2 d2)]
+                         [(fx<= p1 p2)        (go d1 l2) (g2 r2)]
+                         [else                (g2 l2) (go d1 r2)])]
+           [(fx= p1 p2) (go l1 l2) (go r1 r2)]
+           [else        (g1 d1) (g2 d2)]))]
+
+        [else ; ($leaf? d2)
+         (let ([k2 ($leaf-key d2)])
+           (let merge*0 ([d1 d1])
+             (cond
+              [(eq? d1 d2)
+               (id d1)]
+
+              [($branch? d1)
+               (let-branch ([(p1 m1 l1 r1) d1])
+                (cond [(nomatch? k2 p1 m1) (g1 d1) (g2 d2)]
+                      [(fx<= k2 p1)        (merge*0 l1) (g1 r1)]
+                      [else                (g1 l1) (merge*0 r1)]))]
+
+              [else ; ($leaf? d1)
+               (let ([k1 ($leaf-key d1)])
+                 (cond [(fx= k1 k2) (f d1 d2)]
+                       [else        (g1 d1) (g2 d2)]))])))])]
+
+      [($leaf? d1)
+       (let ([k1 ($leaf-key d1)])
+         (let merge*0 ([d2 d2])
+           (cond
+            [(eq? d1 d2)
+             (id d1)]
+
+            [($branch? d2)
+             (let-branch ([(p2 m2 l2 r2) d2])
+              (cond [(nomatch? k1 p2 m2) (g1 d1) (g2 d2)]
+                    [(fx<= k1 p2)        (merge*0 l2) (g2 r2)]
+                    [else                (g2 l2) (merge*0 r2)]))]
+
+            [else ; ($leaf? d2)
+             (let ([k2 ($leaf-key d2)])
+               (cond [(fx= k1 k2) (f d1 d2)]
+                     [else        (g1 d1) (g2 d2)]))])))]))
+
+   (cond
+    [(eq? d1 d2)
+     (id d1)]
+    [(eq? empty-fxmap d1)
+     (g2 d2)]
+    [(eq? empty-fxmap d2)
+     (g1 d1)]
+    [else
+     (merge* f id g1 g2 d1 d2)])
+   (void))
+
+ ;; for-each
+
+ (define (fxmap-for-each g1 d1)
+   (cond
+     [($branch? d1)
+      (fxmap-for-each g1 ($branch-left d1))
+      (fxmap-for-each g1 ($branch-right d1))]
+     [($leaf? d1)
+      (g1 ($leaf-key d1) ($leaf-val d1))]
+     [else ; (eq? empty-fxmap d1)
+      (void)])
+   (void))
+
+ (define (fxmap-for-each/diff f g1 g2 d1 d2)
+   (fxmap-merge* (lambda (x y) (f ($leaf-key x) ($leaf-val x) ($leaf-val y)))
+                 (lambda (x) (void))
+                 (lambda (x) (fxmap-for-each g1 x))
+                 (lambda (x) (fxmap-for-each g2 x))
+                 d1
+                 d2)
+   (void))
+)
diff --git a/s/interpret.ss b/s/interpret.ss
index 9d2c3aa703..59aff4a6fb 100644
--- a/s/interpret.ss
+++ b/s/interpret.ss
@@ -661,6 +661,11 @@
           (c-var-index-set! (car vars) i)
           (loop (cdr vars) regs (fx+ i 1))])))))
 
+(define (cptypes x)
+  (if (enable-type-recovery)
+      ($cptypes x))
+      x)
+
 (define-pass interpret-Lexpand : Lexpand (ir situation for-import? ofn eoo) -> * (val)
   (definitions
     (define (ibeval x1)
@@ -670,9 +675,9 @@
                            (let ([x ((run-cp0)
                                      (lambda (x)
                                        (set! cpletrec-ran? #t)
-                                       ($cpletrec ($cp0 x #f)))
+                                       ($cpletrec (cptypes ($cp0 x #f))))
                                      x2)])
-                             (if cpletrec-ran? x ($cpletrec x))))]
+                             (if cpletrec-ran? x ($cpletrec (cptypes x)))))]
                     [x2b ($cpcheck x2a)]
                     [x2b ($cpcommonize x2b)])
                (when eoo (pretty-print ($uncprep x2b) eoo))
diff --git a/s/patch.ss b/s/patch.ss
index c3ad5fb24c..af30b4261b 100644
--- a/s/patch.ss
+++ b/s/patch.ss
@@ -13,7 +13,7 @@
 ;;; See the License for the specific language governing permissions and
 ;;; limitations under the License.
 
-(define ($value x) x)
+(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
 
 (printf "loading ~s cross compiler~%" (constant machine-type-name))
 
diff --git a/s/primdata.ss b/s/primdata.ss
index 422fc829dc..feb06949f5 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -16,23 +16,23 @@
 ;;; r6rs features
 
 (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic bitwise)] [flags primitive proc])
-  (bitwise-not [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard])
-  (bitwise-and [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
-  (bitwise-ior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
-  (bitwise-xor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
-  (bitwise-if [sig [(sint sint sint) -> (sint)]] [flags arith-op mifoldable discard])
-  (bitwise-bit-count [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard])
-  (bitwise-length [sig [(sint) -> (uint)]] [flags arith-op mifoldable discard])
-  (bitwise-first-bit-set [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard])
-  (bitwise-bit-set? [sig [(sint uint) -> (boolean)]] [flags pure mifoldable discard])
-  (bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard])
-  (bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard])
-  (bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard])
-  (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03])
-  (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03])
-  (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03])
-  (bitwise-rotate-bit-field [sig [(sint sub-uint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard])
-  (bitwise-reverse-bit-field [sig [(sint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard])
+  (bitwise-not [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-and [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
+  (bitwise-ior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
+  (bitwise-xor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
+  (bitwise-if [sig [(sint sint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-bit-count [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-length [sig [(sint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-first-bit-set [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-bit-set? [sig [(sint uint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
+  (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
+  (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
+  (bitwise-rotate-bit-field [sig [(sint sub-uint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (bitwise-reverse-bit-field [sig [(sint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
 )
 
 (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic fixnums)] [flags primitive proc])
@@ -40,18 +40,18 @@
   (fixnum-width [sig [() -> (fixnum)]] [flags pure unrestricted true cp02])
   (least-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02])
   (greatest-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02])
-  (fx<? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02])    ; restricted to 2+ arguments
-  (fx<=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02])   ; restricted to 2+ arguments
-  (fx=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02])    ; restricted to 2+ arguments
-  (fx>? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02])    ; restricted to 2+ arguments
-  (fx>=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02])   ; restricted to 2+ arguments
-  (fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
-  (fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
-  (fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
-  (fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
-  (fxodd? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
-  (fxmax [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02])
-  (fxmin [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02])
+  (fx<? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])    ; restricted to 2+ arguments
+  (fx<=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])   ; restricted to 2+ arguments
+  (fx=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])    ; restricted to 2+ arguments
+  (fx>? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])    ; restricted to 2+ arguments
+  (fx>=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])   ; restricted to 2+ arguments
+  (fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
+  (fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
+  (fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
+  (fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
+  (fxodd? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
+  (fxmax [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
+  (fxmin [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
   ((r6rs: fx*) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder])  ; restricted to 2 arguments
   ((r6rs: fx+) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder])  ; restricted to 2 arguments
   ((r6rs: fx-) [sig [(fixnum) (fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder])  ; restricted to 1 or 2 arguments
@@ -61,17 +61,17 @@
   (fxdiv0-and-mod0 [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard])
   (fxdiv0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
   (fxmod0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02])
-  (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02])
-  (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02])
-  (fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
-  (fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
-  (fxxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
-  (fxif [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
+  (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
+  (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
+  (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02 safeongoodargs])
+  (fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
+  (fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
+  (fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
+  (fxxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
+  (fxif [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
+  (fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
+  (fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
+  (fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
   (fxbit-set? [sig [(fixnum sub-ufixnum) -> (boolean)]] [flags pure cp02])
   (fxcopy-bit [sig [(fixnum sub-ufixnum bit) -> (fixnum)]] [flags arith-op cp02])
   (fxbit-field [sig [(fixnum sub-ufixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02 cp03])
@@ -90,28 +90,28 @@
 
 (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc])
   (flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard])
-  (fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])             ; restricted to 2+ arguments
-  (fl<? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])             ; restricted to 2+ arguments
-  (fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])            ; restricted to 2+ arguments
-  (fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])             ; restricted to 2+ arguments
-  (fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])            ; restricted to 2+ arguments
-  (flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
+  (real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])             ; restricted to 2+ arguments
+  (fl<? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])             ; restricted to 2+ arguments
+  (fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])            ; restricted to 2+ arguments
+  (fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])             ; restricted to 2+ arguments
+  (fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])            ; restricted to 2+ arguments
+  (flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
   (flodd? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
   (fleven? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (flfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (flinfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard])
-  (fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder])
-  (fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder])
-  (fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder])
-  (fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder])
-  (flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
+  (flfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (flinfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
+  (fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
+  (fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
+  (fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
+  (flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
   (fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard])
   (fldiv [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
   (flmod [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
@@ -120,25 +120,25 @@
   (flmod0 [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
   (flnumerator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
   (fldenominator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flfloor [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
+  (flfloor [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
   (make-no-infinities-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc])
   (no-infinities-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard])
   (make-no-nans-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc])
   (no-nans-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard])
-  (fixnum->flonum [sig [(fixnum) -> (flonum)]] [flags arith-op cp02])
+  (fixnum->flonum [sig [(fixnum) -> (flonum)]] [flags arith-op cp02 safeongoodargs])
 )
 
 (define-symbol-flags* ([libraries (rnrs) (rnrs base) (rnrs exceptions)] [flags keyword])
@@ -192,30 +192,30 @@
   (real-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (rational-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (integer-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
-  (inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
-  (inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard])
-  (exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard])
-  ((r6rs: <) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])   ; restricted to 2+ arguments
-  ((r6rs: <=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])  ; restricted to 2+ arguments
-  ((r6rs: =) [sig [(number number number ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])   ; restricted to 2+ arguments
-  ((r6rs: >) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])   ; restricted to 2+ arguments
-  ((r6rs: >=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])  ; restricted to 2+ arguments
-  (zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
-  (positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
-  (negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
-  (odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
-  (even? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])
-  (finite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard])
-  (infinite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard])
-  (nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard])
-  (max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
-  (min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
-  (+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
-  (* [sig [(number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
-  (- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
+  (exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
+  (inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
+  (inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs])
+  (exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard safeongoodargs])
+  ((r6rs: <) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])   ; restricted to 2+ arguments
+  ((r6rs: <=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])  ; restricted to 2+ arguments
+  ((r6rs: =) [sig [(number number number ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])   ; restricted to 2+ arguments
+  ((r6rs: >) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])   ; restricted to 2+ arguments
+  ((r6rs: >=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])  ; restricted to 2+ arguments
+  (zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
+  (positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
+  (negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
+  (odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
+  (even? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])
+  (finite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (infinite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
+  (* [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
+  (- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
   (/ [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
-  (abs [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (abs [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (div-and-mod [sig [(number number) -> (number number)]] [flags discard])
   (div [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
   (mod [sig [(number number) -> (number)]] [flags arith-op mifoldable discard])
@@ -226,11 +226,11 @@
   (lcm [sig [(number ...) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (numerator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs])
   (denominator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs])
-  (floor [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (ceiling [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (round [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (rationalize [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (floor [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (ceiling [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (round [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (rationalize [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (exp [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (log [sig [(number) (number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (sin [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
@@ -242,22 +242,22 @@
   (sqrt [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags discard discard]) ; could be mifoldable if multiple values were handled
   (expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold
-  (make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (real-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (imag-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (angle [sig [(number) -> (real)]] [flags arith-op mifoldable discard ieee r5rs])
+  (make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (real-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (imag-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (angle [sig [(number) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   ((r6rs: number->string) [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc ieee r5rs]) ; radix restricted to 2, 4, 8, 16
   ((r6rs: string->number) [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard ieee r5rs]) ; radix restricted to 2, 4, 8, 16
   (not [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs cp02])
   (boolean? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
-  (boolean=? [sig [(boolean boolean boolean ...) -> (boolean)]] [flags pure mifoldable discard cp03])
+  (boolean=? [sig [(boolean boolean boolean ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs])
   (pair? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
   (cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs])
  ; c..r non-alphabetic so marks come before references
-  (car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 ieee r5rs])
-  (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 ieee r5rs])
+  (car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs])
+  (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs])
   (caar [sig [(#2=(#1# . ptr)) -> (ptr)]] [flags mifoldable discard ieee r5rs])
   (cdar [sig [(#2#) -> (ptr)]] [flags mifoldable discard ieee r5rs])
   (cadr [sig [(#3=(ptr . #1#)) -> (ptr)]] [flags mifoldable discard ieee r5rs])
@@ -297,40 +297,40 @@
   (map [sig [(procedure list list ...) -> (list)]] [flags cp02 cp03 ieee r5rs true])
   (for-each [sig [(procedure list list ...) -> (ptr ...)]] [flags cp02 cp03 ieee r5rs])
   (symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
-  (symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard ieee r5rs])
-  (symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03])
-  (string->symbol [sig [(string) -> (symbol)]] [flags true mifoldable discard ieee r5rs])
+  (symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard safeongoodargs ieee r5rs])
+  (symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs])
+  (string->symbol [sig [(string) -> (symbol)]] [flags true mifoldable discard safeongoodargs ieee r5rs])
   (char? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
-  (char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard true ieee r5rs])
+  (char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard safeongoodargs true ieee r5rs])
   (integer->char [sig [(sub-ufixnum) -> (char)]] [flags pure mifoldable discard true ieee r5rs])
-  ((r6rs: char<=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments
-  ((r6rs: char<?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])  ; restricted to 2+ arguments
-  ((r6rs: char=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs cp03])  ; restricted to 2+ arguments
-  ((r6rs: char>=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments
-  ((r6rs: char>?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs])  ; restricted to 2+ arguments
+  ((r6rs: char<=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
+  ((r6rs: char<?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])  ; restricted to 2+ arguments
+  ((r6rs: char=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs cp03])  ; restricted to 2+ arguments
+  ((r6rs: char>=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments
+  ((r6rs: char>?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs])  ; restricted to 2+ arguments
   (string? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
   (make-string [sig [(length) (length char) -> (string)]] [flags alloc ieee r5rs])
-  (string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02])
-  (string-length [sig [(string) -> (length)]] [flags pure true ieee r5rs mifoldable discard])
+  (string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02 safeongoodargs])
+  (string-length [sig [(string) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs])
   (string-ref [sig [(string sub-index) -> (ptr)]] [flags true ieee r5rs mifoldable discard cp02])
-  ((r6rs: string<=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs])  ; restricted to 2+ arguments
-  ((r6rs: string<?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs])   ; restricted to 2+ arguments
-  ((r6rs: string=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs cp03])   ; restricted to 2+ arguments
-  ((r6rs: string>=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs])  ; restricted to 2+ arguments
-  ((r6rs: string>?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs])   ; restricted to 2+ arguments
+  ((r6rs: string<=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])  ; restricted to 2+ arguments
+  ((r6rs: string<?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])   ; restricted to 2+ arguments
+  ((r6rs: string=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs cp03])   ; restricted to 2+ arguments
+  ((r6rs: string>=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])  ; restricted to 2+ arguments
+  ((r6rs: string>?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])   ; restricted to 2+ arguments
   (substring [sig [(string sub-length sub-length) -> (string)]] [flags alloc ieee r5rs])
-  (string-append [sig [(string ...) -> (string)]] [flags alloc ieee r5rs])
-  (string->list [sig [(string) -> (list)]] [flags alloc ieee r5rs])
+  (string-append [sig [(string ...) -> (string)]] [flags alloc safeongoodargs ieee r5rs])
+  (string->list [sig [(string) -> (list)]] [flags alloc safeongoodargs ieee r5rs])
   (list->string [sig [(sub-list) -> (string)]] [flags alloc ieee r5rs])
   (string-for-each [sig [(procedure string string ...) -> (void)]] [flags cp03])
-  (string-copy [sig [(string) -> (string)]] [flags alloc ieee r5rs])
+  (string-copy [sig [(string) -> (string)]] [flags alloc safeongoodargs ieee r5rs])
   (vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
   (make-vector [sig [(length) (length ptr) -> (vector)]] [flags alloc ieee r5rs])
   (vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02])
-  (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard])
+  (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs])
   (vector-ref [sig [(vector sub-index) -> (ptr)]] [flags ieee r5rs mifoldable discard cp02])
   (vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs])
-  (vector->list [sig [(vector) -> (list)]] [flags alloc ieee r5rs])
+  (vector->list [sig [(vector) -> (list)]] [flags alloc safeongoodargs ieee r5rs])
   (list->vector [sig [(list) -> (vector)]] [flags alloc ieee r5rs])
   (vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs])
   (vector-map [sig [(procedure vector vector ...) -> (vector)]] [flags cp03])
@@ -353,16 +353,16 @@
   (native-endianness [sig [() -> (symbol)]] [flags pure unrestricted alloc cp02])
   (bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (make-bytevector [sig [(length) (length u8/s8) -> (bytevector)]] [flags alloc])
-  (bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard])
-  (bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03])
+  (bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard safeongoodargs])
+  (bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs])
   (bytevector-fill! [sig [(bytevector u8/s8) -> (void)]] [flags true])
   (bytevector-copy! [sig [(bytevector sub-length bytevector sub-length sub-length) -> (void)]] [flags true])
-  (bytevector-copy [sig [(bytevector) -> (bytevector)]] [flags alloc])
+  (bytevector-copy [sig [(bytevector) -> (bytevector)]] [flags alloc safeongoodargs])
   (bytevector-u8-ref [sig [(bytevector sub-index) -> (u8)]] [flags true mifoldable discard])
   (bytevector-s8-ref [sig [(bytevector sub-index) -> (s8)]] [flags true mifoldable discard])
   (bytevector-u8-set! [sig [(bytevector sub-index u8) -> (void)]] [flags true])
   (bytevector-s8-set! [sig [(bytevector sub-index s8) -> (void)]] [flags true])
-  (bytevector->u8-list [sig [(bytevector) -> (list)]] [flags alloc])
+  (bytevector->u8-list [sig [(bytevector) -> (list)]] [flags alloc safeongoodargs])
   (u8-list->bytevector [sig [(sub-list) -> (bytevector)]] [flags alloc])
   (bytevector-uint-ref [sig [(bytevector sub-index symbol sub-length) -> (uint)]] [flags true mifoldable discard])
   (bytevector-sint-ref [sig [(bytevector sub-index symbol sub-length) -> (sint)]] [flags true mifoldable discard])
@@ -535,9 +535,9 @@
   (hashtable-hash-function [sig [(hashtable) -> (ptr)]] [flags])
   (hashtable-mutable? [sig [(hashtable) -> (boolean)]] [flags mifoldable discard])
   (equal-hash [sig [(ptr) -> (length)]] [flags unrestricted true])
-  (string-hash [sig [(string) -> (length)]] [flags true])
-  (string-ci-hash [sig [(string) -> (length)]] [flags true])
-  (symbol-hash [sig [(symbol) -> (length)]] [flags true])
+  (string-hash [sig [(string) -> (length)]] [flags true safeongoodargs])
+  (string-ci-hash [sig [(string) -> (length)]] [flags true safeongoodargs])
+  (symbol-hash [sig [(symbol) -> (length)]] [flags true safeongoodargs])
 )
 
 (define-symbol-flags* ([libraries (rnrs) (rnrs io ports)] [flags keyword])
@@ -729,8 +729,8 @@
 )
 
 (define-symbol-flags* ([libraries (rnrs r5rs)] [flags primitive proc])
-  (exact->inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard ieee r5rs])
-  (inexact->exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard ieee r5rs])
+  (exact->inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
+  (inexact->exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs])
   (quotient [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (remainder [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
   (modulo [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
@@ -871,9 +871,9 @@
   (make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)]
                   [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]]
              [flags alloc])
-  (make-time [sig [(sub-symbol sub-ufixnum sub-fixnum) -> (time)]] [flags alloc])
+  (make-time [sig [(sub-symbol sub-ufixnum exact-integer) -> (time)]] [flags alloc])
   (set-time-nanosecond! [sig [(time sub-uint) -> (void)]] [flags true])
-  (set-time-second! [sig [(time sub-fixnum) -> (void)]] [flags true])
+  (set-time-second! [sig [(time exact-integer) -> (void)]] [flags true])
   (set-time-type! [sig [(time sub-symbol) -> (void)]] [flags true])
   (subtract-duration (sig [(time time) -> (time)]) [flags alloc])
   (subtract-duration! (sig [(time time) -> (time)]) [flags alloc])
@@ -886,7 +886,7 @@
   (time-difference (sig [(time time) -> (time)]) [flags alloc])
   (time-difference! (sig [(time time) -> (time)]) [flags alloc])
   (time-nanosecond [sig [(time) -> (uint)]] [flags mifoldable discard true])
-  (time-second [sig [(time) -> (fixnum)]] [flags mifoldable discard true])
+  (time-second [sig [(time) -> (exact-integer)]] [flags mifoldable discard true])
   (time-type [sig [(time) -> (symbol)]] [flags mifoldable discard true])
   (time-utc->date [sig [(time) (time sub-fixnum) -> (date)]] [flags alloc])
 )
@@ -951,6 +951,7 @@
   (enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (enable-object-backreferences [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
+  (enable-type-recovery [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags])
   (expand-omit-library-invocations [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])
@@ -1108,17 +1109,17 @@
 )
 
 (define-symbol-flags* ([libraries] [flags primitive proc])
-  (< [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard])           ; not restricted to 2+ arguments
-  (<= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard])          ; not restricted to 2+ arguments
-  (= [sig [(number number ...) -> (boolean)]] [flags pure mifoldable discard])           ; not restricted to 2+ arguments
-  (> [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard])           ; not restricted to 2+ arguments
-  (>= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard])          ; not restricted to 2+ arguments
-  (-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
-  (1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
-  (1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
+  (< [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])           ; not restricted to 2+ arguments
+  (<= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])          ; not restricted to 2+ arguments
+  (= [sig [(number number ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])           ; not restricted to 2+ arguments
+  (> [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])           ; not restricted to 2+ arguments
+  (>= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])          ; not restricted to 2+ arguments
+  (-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
+  (1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
+  (1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
   (abort [sig [() (ptr) -> (bottom)]] [flags abort-op])
   (acosh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
-  (add1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
+  (add1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
   (andmap [sig [(procedure list list ...) -> (ptr ...)]] [flags cp03])
   (annotation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (annotation-expression [sig [(annotation) -> (ptr)]] [flags pure mifoldable discard true])
@@ -1181,27 +1182,27 @@
   (call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs])      ; has options argument
   (call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs])     ; has options argument
   (call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
-  (cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
-  (cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
-  (cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
+  (cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
+  (cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
+  (cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs])
   (cfl/ [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
-  (cfl= [sig [(cflonum cflonum ...) -> (boolean)]] [flags pure mifoldable discard])
-  (cfl-conjugate [sig [(cflonum) -> (cflonum)]] [flags arith-op mifoldable discard])
-  (cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard])
+  (cfl= [sig [(cflonum cflonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (cfl-conjugate [sig [(cflonum) -> (cflonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
   (cflonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (char<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard])     ; not restricted to 2+ arguments
-  (char<? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard])      ; not restricted to 2+ arguments
-  (char=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03])      ; not restricted to 2+ arguments
-  (char>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard])     ; not restricted to 2+ arguments
-  (char>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard])      ; not restricted to 2+ arguments
-  (char- [sig [(char char) -> (fixnum)]] [flags pure mifoldable discard true])
-  (char-ci<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard])  ; not restricted to 2+ arguments
-  (char-ci<? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard])   ; not restricted to 2+ arguments
-  (char-ci=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03])   ; not restricted to 2+ arguments
-  (char-ci>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard])  ; not restricted to 2+ arguments
-  (char-ci>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard])   ; not restricted to 2+ arguments
+  (char<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])     ; not restricted to 2+ arguments
+  (char<? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])      ; not restricted to 2+ arguments
+  (char=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs])      ; not restricted to 2+ arguments
+  (char>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])     ; not restricted to 2+ arguments
+  (char>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])      ; not restricted to 2+ arguments
+  (char- [sig [(char char) -> (fixnum)]] [flags pure mifoldable discard true safeongoodargs])
+  (char-ci<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])  ; not restricted to 2+ arguments
+  (char-ci<? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])   ; not restricted to 2+ arguments
+  (char-ci=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs])   ; not restricted to 2+ arguments
+  (char-ci>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])  ; not restricted to 2+ arguments
+  (char-ci>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])   ; not restricted to 2+ arguments
   (char-name [sig [(sub-ptr) (sub-symbol maybe-char) -> (ptr)]] [flags])
   (char-ready? [sig [() (textual-input-port) -> (boolean)]] [flags ieee r5rs])
   (chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags])
@@ -1299,16 +1300,16 @@
   (port-file-compressed! [sig [(port) -> (void)]] [flags])
   (file-regular? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard])
   (file-symbolic-link? [sig [(pathname) -> (boolean)]] [flags discard])
-  (fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard])
-  (fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [flags arith-op mifoldable discard])
+  (fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [flags arith-op mifoldable discard safeongoodargs])
   (flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02])
-  (flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard])
-  (fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])   ; not restricted to 2+ arguments
-  (fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])   ; not restricted to 2+ arguments
-  (fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])  ; not restricted to 2+ arguments
-  (fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])   ; not restricted to 2+ arguments
-  (fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard])  ; not restricted to 2+ arguments
+  (flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])   ; not restricted to 2+ arguments
+  (fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])   ; not restricted to 2+ arguments
+  (fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])  ; not restricted to 2+ arguments
+  (fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])   ; not restricted to 2+ arguments
+  (fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])  ; not restricted to 2+ arguments
   (flush-output-port [sig [() (output-port) -> (void)]] [flags true])   ; not restricted to 1 argument
   (foreign-entry? [sig [(string) -> (boolean)]] [flags discard])
   (foreign-entry [sig [(string) -> (uptr)]] [flags discard true])
@@ -1336,39 +1337,39 @@
   (fx/ [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])  ; not restricted to 1 or 2 arguments
   (fx1+ [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
   (fx1- [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fx< [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02])   ; not restricted to 2+ arguments
-  (fx<= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02])  ; not restricted to 2+ arguments
-  (fx= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02])   ; not restricted to 2+ arguments
-  (fx> [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02])   ; not restricted to 2+ arguments
-  (fx>= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02])  ; not restricted to 2+ arguments
+  (fx< [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])   ; not restricted to 2+ arguments
+  (fx<= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])  ; not restricted to 2+ arguments
+  (fx= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])   ; not restricted to 2+ arguments
+  (fx> [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])   ; not restricted to 2+ arguments
+  (fx>= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs])  ; not restricted to 2+ arguments
   (fxabs [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
   (fxlogand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
   (fxlogbit? [sig [(ufixnum fixnum) -> (boolean)]] [flags pure cp02])
   (fxlogbit0 [sig [(sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
   (fxlogbit1 [sig [(sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fxlogior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
-  (fxlognot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fxlogor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
-  (fxlogtest [sig [(fixnum fixnum) -> (boolean)]] [flags pure cp02])
-  (fxlogxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
+  (fxlogior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
+  (fxlognot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs])
+  (fxlogor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
+  (fxlogtest [sig [(fixnum fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
+  (fxlogxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
   (fxmodulo [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fxnonnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
-  (fxnonpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02])
+  (fxnonnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
+  (fxnonpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs])
   (fxquotient [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
   (fxremainder [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
   (fxsll [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
   (fxsra [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
   (fxsrl [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02])
-  (fxvector->list [sig [(fxvector) -> (list)]] [flags alloc])
-  (fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc])
+  (fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02 safeongoodargs])
+  (fxvector->list [sig [(fxvector) -> (list)]] [flags alloc safeongoodargs])
+  (fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs])
   (fxvector-fill! [sig [(fxvector fixnum) -> (void)]] [flags true])
-  (fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc])
-  (fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true])
+  (fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs])
+  (fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true safeongoodargs])
   (fxvector-ref [sig [(fxvector sub-index) -> (fixnum)]] [flags mifoldable discard cp02])
   (fxvector-set! [sig [(fxvector sub-index fixnum) -> (void)]] [flags true])
   (fxvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc])
+  (gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc safeongoodargs])
   (gensym? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (gensym->unique-string [sig [(gensym) -> (string)]] [flags true mifoldable]) ; can't discard ... if we have our hands on it, it must be in the oblist after this
   (get-bytevector-some! [sig [(binary-input-port bytevector length length) -> (ptr)]] [flags true])
@@ -1422,15 +1423,15 @@
   (lock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
   (locked-object? [sig [(ptr) -> (boolean)]] [flags unrestricted discard])
   (logand [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
-  (logbit? [sig [(uint sint) -> (boolean)]] [flags pure mifoldable discard])
+  (logbit? [sig [(uint sint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
   (logbit0 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard])
   (logbit1 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard])
-  (logior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
-  (lognot [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard])
-  (logor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
-  (logtest [sig [(sint sint) -> (boolean)]] [flags pure mifoldable discard])
-  (logxor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
-  (magnitude-squared [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
+  (logior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
+  (lognot [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
+  (logor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
+  (logtest [sig [(sint sint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
+  (logxor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
+  (magnitude-squared [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
   (make-annotation [sig [(ptr source-object ptr) (ptr source-object ptr annotation-options) -> (annotation)]] [flags pure true mifoldable discard])
   (make-arity-wrapper-procedure [sig [(procedure sint ptr) -> (procedure)]] [flags pure true mifoldable discard])
   (make-boot-file [sig [(pathname sub-list pathname ...) -> (void)]] [flags true])
@@ -1528,7 +1529,7 @@
   (pretty-format [sig [(symbol) -> (ptr)] [(symbol sub-ptr) -> (void)]] [flags])
   (pretty-print [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags true])
   (printf [sig [(string sub-ptr ...) -> (void)]] [flags true])
-  (procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard true])
+  (procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard safeongoodargs true])
   (process [sig [(string) -> (list)]] [flags])
   (profile-clear-database [sig [() -> (void)]] [flags true])
   (profile-clear [sig [() -> (void)]] [flags true])
@@ -1536,12 +1537,12 @@
   (profile-dump-data [sig [(pathname) (pathname sub-list) -> (void)]] [flags true])
   (profile-dump-list [sig [() (ptr) (ptr sub-list) -> (list)]] [flags discard true])
   (profile-dump-html [sig [() (pathname) (pathname sub-list) -> (void)]] [flags true])
-  (property-list [sig [(symbol) -> (list)]] [flags discard true])
+  (property-list [sig [(symbol) -> (list)]] [flags discard true safeongoodargs])
   (put-bytevector-some [sig [(binary-output-port bytevector) (binary-output-port bytevector length) (binary-output-port bytevector length length) -> (uint)]] [flags true])
   (put-hash-table! [sig [(old-hash-table ptr ptr) -> (void)]] [flags true])
   (put-registry! [feature windows] [sig [(string string) -> (void)]] [flags true])
   (put-string-some [sig [(textual-output-port string) (textual-output-port string length) (textual-output-port string length length) -> (uint)]] [flags true])
-  (putprop [sig [(symbol ptr ptr) -> (void)]] [flags true])
+  (putprop [sig [(symbol ptr ptr) -> (void)]] [flags true safeongoodargs])
   (putenv [sig [(string string) -> (void)]] [flags true])
   (profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags unrestricted discard])
   (random [sig [(sub-number) -> (number)]] [flags alloc])
@@ -1562,7 +1563,7 @@
   (remove-hash-table! [sig [(old-hash-table ptr) -> (void)]] [flags true])
   (remove-registry! [feature windows] [sig [(string) -> (void)]] [flags true])
   (remove! [sig [(ptr list) -> (list)]] [flags true])
-  (remprop [sig [(symbol ptr) -> (void)]] [flags])
+  (remprop [sig [(symbol ptr) -> (void)]] [flags safeongoodargs])
   (remq! [sig [(ptr list) -> (list)]] [flags true])
   (remv! [sig [(ptr list) -> (list)]] [flags true])
   (rename-file [sig [(pathname ptr) -> (void)]] [flags])
@@ -1642,21 +1643,21 @@
   (statistics [sig [() -> (sstats)]] [flags unrestricted alloc])
   (string->multibyte [feature windows] [sig [(sub-uint string) -> (bytevector)]] [flags true discard])
   (string->number [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard]) ; radix not restricted to 2, 4, 8, 16
-  (string<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard])        ; not restricted to 2+ arguments
-  (string<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard])         ; not restricted to 2+ arguments
-  (string=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard cp03])         ; not restricted to 2+ arguments
-  (string>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard])        ; not restricted to 2+ arguments
-  (string>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard])         ; not restricted to 2+ arguments
-  (string-ci<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs])  ; not restricted to 2+ arguments
-  (string-ci<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs])   ; not restricted to 2+ arguments
-  (string-ci=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs cp03])   ; not restricted to 2+ arguments
-  (string-ci>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs])  ; not restricted to 2+ arguments
-  (string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs])   ; not restricted to 2+ arguments
+  (string<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs])        ; not restricted to 2+ arguments
+  (string<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs])         ; not restricted to 2+ arguments
+  (string=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs])         ; not restricted to 2+ arguments
+  (string>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs])        ; not restricted to 2+ arguments
+  (string>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs])         ; not restricted to 2+ arguments
+  (string-ci<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])  ; not restricted to 2+ arguments
+  (string-ci<? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])   ; not restricted to 2+ arguments
+  (string-ci=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs cp03])   ; not restricted to 2+ arguments
+  (string-ci>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])  ; not restricted to 2+ arguments
+  (string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs])   ; not restricted to 2+ arguments
   (string-copy! [sig [(string sub-length string sub-length sub-length) -> (void)]] [flags true])
-  (string->immutable-string [sig [(string) -> (string)]] [flags alloc])
+  (string->immutable-string [sig [(string) -> (string)]] [flags alloc safeongoodargs])
   (string-truncate! [sig [(string length) -> (string)]] [flags true])
   (strip-fasl-file [sig [(pathname pathname fasl-strip-options) -> (void)]] [flags true])
-  (sub1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
+  (sub1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs])
   (subst [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc])
   (subst! [sig [(ptr ptr ptr) -> (ptr)]] [flags])
   (substq [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc])
@@ -1699,7 +1700,7 @@
   (transcript-on [sig [(pathname) -> (void)]] [flags true ieee r5rs])
   (truncate-file [sig [(output-port) (output-port sub-ptr) -> (void)]] [flags])
   (truncate-port [sig [(output-port) (output-port sub-ptr) -> (void)]] [flags])
-  (unbox [sig [(box) -> (ptr)]] [flags mifoldable discard])
+  (unbox [sig [(box) -> (ptr)]] [flags mifoldable discard safeongoodargs])
   (unget-u8 [sig [(binary-input-port ptr) -> (void)]] [flags true])
   (unget-char [sig [(textual-input-port ptr) -> (void)]] [flags true])
   (unlock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
@@ -1708,8 +1709,8 @@
   (utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true])
   (utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true])
   (vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags])
-  (vector-copy [sig [(vector) -> (vector)]] [flags alloc])
-  (vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc])
+  (vector-copy [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
+  (vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
   (vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true])
   (virtual-register [sig [(sub-index) -> (ptr)]] [flags discard])
   (virtual-register-count [sig [() -> (length)]] [flags pure unrestricted true cp02])
@@ -1792,6 +1793,7 @@
   ($continuation-attachments [flags])
   ($cp0 [flags])
   ($cpcheck [flags])
+  ($cptypes [flags])
   ($cpcheck-prelex-flags [flags])
   ($cpcommonize [flags])
   ($cpletrec [flags])
diff --git a/s/primref.ss b/s/primref.ss
index 6f734bb8e8..16438fc667 100644
--- a/s/primref.ss
+++ b/s/primref.ss
@@ -14,9 +14,9 @@
 ;;; limitations under the License.
 
 (define-record-type primref
-  (nongenerative #{primref a0xltlrcpeygsahopkplcn-2})
+  (nongenerative #{primref a0xltlrcpeygsahopkplcn-3})
   (sealed #t)
-  (fields name flags arity))
+  (fields name flags arity signatures))
 
 (define primref-level
   (lambda (pr)
diff --git a/s/primvars.ss b/s/primvars.ss
index abff2037a6..8dc5154da0 100644
--- a/s/primvars.ss
+++ b/s/primvars.ss
@@ -18,7 +18,7 @@
   (include "primref.ss")
 
   (define record-prim!
-    (lambda (prim unprefixed flags arity boolean-valued? result-arity)
+    (lambda (prim unprefixed flags arity boolean-valued? result-arity signatures)
       (unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed))
       (let* ([flags (if boolean-valued? (fxlogor flags (prim-mask boolean-valued)) flags)]
              [flags (if (eq? 'single result-arity) (fxlogor flags (prim-mask single-valued)) flags)]
@@ -27,13 +27,13 @@
           ($oops 'prims "inconsistent single-value information for ~s" prim))
         ($sputprop prim '*flags* flags)
         (when (any-set? (prim-mask (or primitive system)) flags)
-          ($sputprop prim '*prim2* (make-primref prim flags arity))
-          ($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity))))))
+          ($sputprop prim '*prim2* (make-primref prim flags arity signatures))
+          ($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity signatures))))))
 
   (define-syntax setup
     (lambda (x)
       (import priminfo)
-     ; sort vector of primitive names so boot files compare equal
+      ; sort vector of primitive names so boot files compare equal
       (let ([v-prim (vector-sort (lambda (x y) (string<=? (symbol->string x) (symbol->string y))) (primvec))])
         (let ([v-info (vector-map get-priminfo v-prim)])
           #`(vector-for-each record-prim!
@@ -42,7 +42,8 @@
               '#,(datum->syntax #'* (vector-map priminfo-mask v-info))
               '#,(datum->syntax #'* (vector-map priminfo-arity v-info))
               '#,(datum->syntax #'* (vector-map priminfo-boolean? v-info))
-              '#,(datum->syntax #'* (vector-map priminfo-result-arity v-info)))))))
+              '#,(datum->syntax #'* (vector-map priminfo-result-arity v-info))
+              '#,(datum->syntax #'* (vector-map priminfo-signatures v-info)))))))
 
   (for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist))
   setup)