add list-assuming-immutable?

Build in a Racket-style `list?` using GC cooperation to make recording
the result cheaper.

original commit: 32189af3e4dfc3596fba3163fd1a8295b830448b

c/alloc.c

@@ -444,6 +444,49 @@ ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) {
   return x;
 }
 
+ptr S_list_bits_ref(p) ptr p; {
+  seginfo *si = SegInfo(ptr_get_segment(p));
+
+  if (si->list_bits) {
+    int bit_pos = (segment_bitmap_index(p) & 0x7);
+    return FIX((si->list_bits[segment_bitmap_byte(p)] >> bit_pos) & list_bits_mask);
+  } else
+    return FIX(0);
+}
+
+void S_list_bits_set(p, bits) ptr p; iptr bits; {
+  seginfo *si = SegInfo(ptr_get_segment(p));
+
+  /* This function includes potential races when writing list bits.
+     If a race loses bits, that's ok, as long as it's unlikely. */
+
+  if (!si->list_bits) {
+    ptr list_bits;
+
+    if (si->generation == 0) {
+      ptr tc = get_thread_context();
+      thread_find_room(tc, typemod, ptr_align(segment_bitmap_bytes), list_bits);
+    } else {
+      tc_mutex_acquire()
+
+      find_room(space_data, si->generation, typemod, ptr_align(segment_bitmap_bytes), list_bits);
+      tc_mutex_release()
+    }
+
+    memset(list_bits, 0, segment_bitmap_bytes);
+
+    /* FIXME: A write fence is needed here to make sure `list_bits` is
+       zeroed for everyone who sees it. On x86, TSO takes care of that
+       ordering already. */
+
+    /* beware: racy write here */
+    si->list_bits = list_bits;
+  }
+
+  /* beware: racy read+write here */
+  si->list_bits[segment_bitmap_byte(p)] |= segment_bitmap_bits(p, bits);
+}
+
 /* S_cons_in is always called with mutex */
 ptr S_cons_in(s, g, car, cdr) ISPC s; IGEN g; ptr car, cdr; {
     ptr p;

c/externs.h

@@ -71,6 +71,8 @@ extern void S_scan_dirty PROTO((ptr **p, ptr **endp));
 extern void S_scan_remembered_set PROTO((void));
 extern void S_get_more_room PROTO((void));
 extern ptr S_get_more_room_help PROTO((ptr tc, uptr ap, uptr type, uptr size));
+extern ptr S_list_bits_ref PROTO((ptr p));
+extern void S_list_bits_set PROTO((ptr p, iptr bits));
 extern ptr S_cons_in PROTO((ISPC s, IGEN g, ptr car, ptr cdr));
 extern ptr S_symbol PROTO((ptr name));
 extern ptr S_rational PROTO((ptr n, ptr d));

c/gc.c

@@ -158,6 +158,7 @@ static void check_pending_ephemerons PROTO(());
 static int check_dirty_ephemeron PROTO((ptr pe, int tg, int youngest));
 static void clear_trigger_ephemerons PROTO(());
 static void init_fully_marked_mask();
+static void copy_and_clear_list_bits(seginfo *oldspacesegments, IGEN tg);
 
 #ifdef ENABLE_OBJECT_COUNTS
 static uptr total_size_so_far();
@@ -240,9 +241,11 @@ static ptr sweep_from;
 #if ptr_alignment == 2
 # define record_full_marked_mask 0x55
 # define record_high_marked_mask 0x40
+# define mask_bits_to_list_bits_mask(m) ((m) | ((m) << 1))
 #elif ptr_alignment == 1
 # define record_full_marked_mask 0xFF
 # define record_high_marked_mask 0x80
+# define mask_bits_to_list_bits_mask(m) (m)
 #endif
 
 #define segment_sufficiently_compact_bytes ((bytes_per_segment * 3) / 4)
@@ -263,27 +266,23 @@ uptr list_length(ptr ls) {
 }
 #endif
 
+#define init_mask(dest, tg, init) {                                     \
+    find_room(space_data, tg, typemod, ptr_align(segment_bitmap_bytes), dest); \
+    memset(dest, init, segment_bitmap_bytes);                           \
+  }
+
 #define marked(si, p) (si->marked_mask && (si->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))
 
 static void init_fully_marked_mask() {
-  find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), fully_marked_mask);
-  memset(fully_marked_mask, 0xFF, segment_bitmap_bytes);  
+  init_mask(fully_marked_mask, 0, 0xFF);
 }
 
 #ifdef PRESERVE_FLONUM_EQ
 
 static void flonum_set_forwarded(ptr p, seginfo *si) {
-  if (!si->forwarded_flonums) {
-    ptr ff;
-    find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), ff);
-    memset(ff, 0, segment_bitmap_bytes);
-    si->forwarded_flonums = ff;
-  }
-  {
-    uptr byte = segment_bitmap_byte(p);
-    uptr bit = segment_bitmap_bit(p);
-    si->forwarded_flonums[byte] |= bit;
-  }
+  if (!si->forwarded_flonums)
+    init_mask(si->forwarded_flonums, 0, 0);
+  si->forwarded_flonums[segment_bitmap_byte(p)] |= segment_bitmap_bit(p);
 }
 
 static int flonum_is_forwarded_p(ptr p, seginfo *si) {
@@ -640,10 +639,8 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
          ptr p = Scar(ls);
          seginfo *si = SegInfo(ptr_get_segment(p));
          if (si->space == space_new) {
-           if (!si->marked_mask) {
-             find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->marked_mask);
-             memset(si->marked_mask, 0, segment_bitmap_bytes);  
-           }
+           if (!si->marked_mask)
+             init_mask(si->marked_mask, 0, 0);
            si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p);
          }
        }
@@ -1156,6 +1153,8 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
     }
 #endif /* WIN32 */
 
+    copy_and_clear_list_bits(oldspacesegments, tg);
+
   /* move copied old space segments to empty space, and promote
      marked old space segments to the target generation */
     for (si = oldspacesegments; si != NULL; si = nextsi) {
@@ -2077,6 +2076,72 @@ static uptr target_generation_space_so_far() {
   return sz;
 }
 
+void copy_and_clear_list_bits(seginfo *oldspacesegments, IGEN tg) {
+  seginfo *si;
+  int i;
+
+  /* Update bits that are used by `list-assuming-immutable?`. */
+
+  for (si = oldspacesegments; si != NULL; si = si->next) {
+    if (si->list_bits) {
+      if ((si->generation == 0) && !si->marked_mask) {
+        /* drop generation-0 bits, because probably the relevant pairs
+           were short-lived, and it's ok to recompute them if needed */
+      } else {
+        if (si->marked_mask) {
+          /* Besides marking or copying `si->list_bits`, clear bits
+             where there's no corresopnding mark bit, so we don't try to
+             check forwarding in a future GC */
+          seginfo *bits_si = SegInfo(ptr_get_segment((ptr)si->list_bits));
+        
+          if (bits_si->old_space) {
+            if (bits_si->use_marks) {
+              if (!bits_si->marked_mask)
+                init_mask(bits_si->marked_mask, 0, 0);
+              bits_si->marked_mask[segment_bitmap_byte((ptr)si->list_bits)] |= segment_bitmap_bit((ptr)si->list_bits);
+            } else {
+              octet *copied_bits;
+              find_room(space_data, tg, typemod, ptr_align(segment_bitmap_bytes), copied_bits);
+              memcpy_aligned(copied_bits, si->list_bits, segment_bitmap_bytes);
+              si->list_bits = copied_bits;
+            }
+          }
+
+          for (i = 0; i < segment_bitmap_bytes; i++) {
+            int m = si->marked_mask[i];
+            si->list_bits[i] &= mask_bits_to_list_bits_mask(m);
+          }
+        }
+
+        if (si->use_marks) {
+          /* No forwarding possible from this segment */
+        } else {
+          /* For forwarded pointers, copy over list bits */
+          for (i = 0; i < segment_bitmap_bytes; i++) {
+            if (si->list_bits[i]) {
+              int bitpos;
+              for (bitpos = 0; bitpos < 8; bitpos += ptr_alignment) {
+                int bits = si->list_bits[i] & (list_bits_mask << bitpos);
+                if (bits != 0) {
+                  ptr p = build_ptr(si->number, ((i << (log2_ptr_bytes+3)) + (bitpos << log2_ptr_bytes)));
+                  if (FWDMARKER(p) == forward_marker) {
+                    ptr new_p = FWDADDRESS(p);
+                    seginfo *new_si = SegInfo(ptr_get_segment(new_p));
+                    if (!new_si->list_bits)
+                      init_mask(new_si->list_bits, tg, 0);
+                    bits >>= bitpos;
+                    new_si->list_bits[segment_bitmap_byte(new_p)] |= segment_bitmap_bits(new_p, bits);
+                  }
+                }
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+}
+
 /* **************************************** */
 
 #ifdef ENABLE_MEASURE
@@ -2109,14 +2174,11 @@ static void finish_measure() {
 }
 
 static void init_counting_mask(seginfo *si) {
-  find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->counting_mask);
-  memset(si->counting_mask, 0, segment_bitmap_bytes);
+  init_mask(si->counting_mask, 0, 0);
 }
 
 static void init_measure_mask(seginfo *si) {
-  find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->measured_mask);
-  memset(si->measured_mask, 0, segment_bitmap_bytes);
-  
+  init_mask(si->measured_mask, 0, 0);
   measured_seginfos = S_cons_in(space_new, 0, (ptr)si, measured_seginfos);
 }
 

c/prim.c

@@ -200,6 +200,8 @@ void S_prim_init() {
     Sforeign_symbol("(cs)enable_object_backreferences", (void *)S_enable_object_backreferences);
     Sforeign_symbol("(cs)set_enable_object_backreferences", (void *)S_set_enable_object_backreferences);
     Sforeign_symbol("(cs)object_backreferences", (void *)S_object_backreferences);
+    Sforeign_symbol("(cs)list_bits_ref", (void *)S_list_bits_ref);
+    Sforeign_symbol("(cs)list_bits_set", (void *)S_list_bits_set);
 }
 
 static void s_instantiate_code_object() {

c/segment.c

@@ -58,6 +58,13 @@ void S_segment_init() {
   }
   S_G.number_of_nonstatic_segments = 0;
   S_G.number_of_empty_segments = 0;
+
+  if (seginfo_space_disp != offsetof(seginfo, space))
+    S_error_abort("seginfo_space_disp is wrong");
+  if (seginfo_generation_disp != offsetof(seginfo, generation))
+    S_error_abort("seginfo_generation_disp is wrong");
+  if (seginfo_list_bits_disp != offsetof(seginfo, list_bits))
+    S_error_abort("seginfo_list_bits_disp is wrong");
 }
 
 static uptr membytes = 0;
@@ -232,6 +239,7 @@ static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) {
   si->old_space = 0;
   si->use_marks = 0;
   si->must_mark = 0;
+  si->list_bits = NULL;
   si->min_dirty_byte = 0xff;
   for (d = 0; d < cards_per_segment; d += sizeof(ptr)) {
     iptr *dp = (iptr *)(si->dirty_bytes + d);

c/types.h

@@ -114,10 +114,11 @@ typedef int IFASLCODE;      /* fasl type codes */
 #define addr_get_segment(p) ((uptr)(p) >> segment_offset_bits)
 #define ptr_get_segment(p) (((uptr)(p) + typemod - 1) >> segment_offset_bits)
 
-#define segment_bitmap_bytes    (bytes_per_segment >> (log2_ptr_bytes+3))
-#define segment_bitmap_index(p) ((((uptr)p + (typemod-1)) & (bytes_per_segment - 1)) >> log2_ptr_bytes)
-#define segment_bitmap_byte(p)  (segment_bitmap_index(p) >> 3)
-#define segment_bitmap_bit(p)   ((uptr)1 << (segment_bitmap_index(p) & 0x7))
+#define segment_bitmap_bytes      (bytes_per_segment >> (log2_ptr_bytes+3))
+#define segment_bitmap_index(p)   ((((uptr)(p) + (typemod-1)) & (bytes_per_segment - 1)) >> log2_ptr_bytes)
+#define segment_bitmap_byte(p)    (segment_bitmap_index(p) >> 3)
+#define segment_bitmap_bits(p, b) ((uptr)(b) << (segment_bitmap_index(p) & 0x7))
+#define segment_bitmap_bit(p)     segment_bitmap_bits(p,1)
 
 #define SPACE(p) SegmentSpace(ptr_get_segment(p))
 #define GENERATION(p) SegmentGeneration(ptr_get_segment(p))
@@ -138,6 +139,7 @@ typedef struct _seginfo {
   unsigned char has_triggers : 1;           /* set if trigger_ephemerons or trigger_guardians is set */
   unsigned char must_mark : 2;              /* a form of locking, where 3 counts as "infinite" */
   octet min_dirty_byte;                     /* dirty byte for full segment, effectively min(dirty_bytes) */
+  octet *list_bits;                         /* for `$list-bits-ref` and `$list-bits-set!` */
   uptr number;                              /* the segment number */
   struct _chunkinfo *chunk;                 /* the chunk this segment belongs to */
   struct _seginfo *next;                    /* pointer to the next seginfo (used in occupied_segments and unused_segs */

c/vfasl.c

@@ -523,6 +523,13 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len)
     while (cl != end_closures) {
       ptr code = CLOSCODE(cl);
       code = ptr_add(code, code_delta);
+
+#if 0
+      printf("%p ", code);
+      S_prin1(CODENAME(code));
+      printf("\n");
+#endif
+
       SETCLOSCODE(cl,code);
       cl = ptr_add(cl, size_closure(CLOSLEN(cl)));
     }

csug/objects.stex

@@ -113,6 +113,24 @@ pair containing the last element and the terminating object.
 \endschemedisplay
 
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{list-assuming-immutable?}{\categoryprocedure}{(list-assuming-immutable? \var{v})}
+\returns a boolean
+\listlibraries
+\endentryheader
+
+\noindent
+Like \scheme{list?}, but on the assumption that any pairs involved in the
+result are never mutated further, the result is produced in amoritized
+constant time.
+
+\schemedisplay
+(list-assuming-immutable? '(a b c d)) ;=> #t
+(list-assuming-immutable? '(a b c . d)) ;=> #f
+\endschemedisplay
+
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{list-copy}{\categoryprocedure}{(list-copy \var{list})}

makefiles/Mf-install.in

@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.27
+Version=csv9.5.3.28
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot

mats/5_2.ms

@@ -1338,3 +1338,11 @@
       (eqv? (car ls) 0)
       (eqv? (apply + ls) 4950)))
 )
+
+(mat list-assuming-immutable?
+  (list-assuming-immutable? '(1 2 3))
+  (not (list-assuming-immutable? '(1 2 . 3)))
+  (not (list-assuming-immutable? #t))
+  (not (list-assuming-immutable? 3))
+  (list-assuming-immutable? '())
+  )

s/5_2.ss

@@ -792,3 +792,31 @@
   (set! enumerate
     (lambda (ls)
       ($iota (fx- ($list-length ls 'enumerate) 1) '()))))
+
+(define list-assuming-immutable?
+  ;; Use list bits to record discovered listness:
+  ;;   0 => unknown
+  ;;   1 => is a list
+  ;;   2 => not a list
+  ;; Record this information half-way to the point that the
+  ;; decision is made (i.e., a kind of path compression)
+  (lambda (v)
+    (or (null? v)
+        (and (pair? v)
+             (let loop ([fast (cdr v)] [slow v] [slow-step? #f])
+               (let ([return (lambda (bits)
+                               ($list-bits-set! slow bits)
+                               (fx= bits 1))])
+                 (cond
+                   [(null? fast) (return 1)]
+                   [(not (pair? fast)) (return 2)]
+                   [(eq? fast slow) (return 2)] ; cycle
+                   [else
+                    (let ([bits ($list-bits-ref fast)])
+                      (cond
+                        [(fx= bits 0)
+                         (if slow-step?
+                             (loop (cdr fast) (cdr slow) #f)
+                             (loop (cdr fast) slow #t))]
+                        [else
+                         (return bits)]))])))))))

s/cmacros.ss

@@ -328,7 +328,7 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x0905031B)
+(define-constant scheme-version #x0905031C)
 
 (define-syntax define-machine-types
   (lambda (x)
@@ -412,6 +412,13 @@
 (define-constant ptr-alignment
   (/ (constant byte-alignment) (constant ptr-bytes)))
 
+;; seginfo offsets, must be consistent with `seginfo` in "types.h"
+(define-constant seginfo-space-disp 0)
+(define-constant seginfo-generation-disp 1)
+(define-constant seginfo-list-bits-disp (constant ptr-bytes))
+
+(define-constant list-bits-mask (- (expt 2 (constant ptr-alignment)) 1))
+
 ;;; fasl codes---see fasl.c for documentation of representation
 
 (define-constant fasl-type-header 0)

s/cpnanopass.ss

@@ -5453,7 +5453,7 @@
           (inline-accessor $thread-tc thread-tc-disp)
           )
         (let ()
-          (define (build-maybe-seginfo e)
+          (define (build-seginfo maybe? e)
             (let ([ptr (make-assigned-tmp 'ptr)]
                   [seginfo (make-assigned-tmp 'seginfo)])
               (define (build-level-3 seginfo k)
@@ -5465,9 +5465,11 @@
                                                                                          (constant segment-t2-bits))))
                                                    (immediate ,(constant log2-ptr-bytes)))
                                          ,0)])
-                        (if ,(%inline eq? ,s3 (immediate 0))
-                            (immediate 0)
-                            ,(k s3))))]
+                        ,(if maybe?
+                             `(if ,(%inline eq? ,s3 (immediate 0))
+                                  (immediate 0)
+                                  ,(k s3))
+                             (k s3))))]
                   [else (k seginfo)]))
               (define (build-level-2 s3 k)
                 (constant-case segment-table-levels
@@ -5479,9 +5481,11 @@
                                                        (immediate ,(fxsll (fx- (fxsll 1 (constant segment-t2-bits)) 1)
                                                                           (constant log2-ptr-bytes))))
                                          0)])
-                        (if ,(%inline eq? ,s2 (immediate 0))
-                            (immediate 0)
-                            ,(k s2))))]
+                        ,(if maybe?
+                             `(if ,(%inline eq? ,s2 (immediate 0))
+                                  (immediate 0)
+                                  ,(k s2))
+                             (k s2))))]
                   [else (k s3)]))
               `(let ([,ptr ,(%inline srl ,(%inline + ,e (immediate ,(fx- (constant typemod) 1)))
                                      (immediate ,(constant segment-offset-bits)))])
@@ -5499,7 +5503,7 @@
                  ,(%constant sfalse)
                  (if ,(%type-check mask-immediate type-immediate ,e)
                      ,(%constant sfalse)
-                     ,(let ([s-e (build-maybe-seginfo e)]
+                     ,(let ([s-e (build-seginfo #T e)]
                             [si (make-assigned-tmp 'si)])
                         `(let ([,si ,s-e])
                            (if ,(%inline eq? ,si (immediate 0))
@@ -5514,28 +5518,45 @@
                     ,(%constant sfalse)
                     (if ,(%type-check mask-immediate type-immediate ,e)
                         ,(%constant sfalse)
-                        ,(let ([s-e (build-maybe-seginfo e)]
+                        ,(let ([s-e (build-seginfo #t e)]
                                [si (make-assigned-tmp 'si)])
                            `(let ([,si ,s-e])
                               (if ,(%inline eq? ,si (immediate 0))
                                   ,(%constant sfalse)
                                   ,si))))))])
-          ;; Generation is first unsigned char in `seginfo` as defined in "types.h"
+          (define-inline 2 $seginfo
+            [(e)
+             (bind #t (e) (build-seginfo #f e))])
           (define-inline 2 $seginfo-generation
             [(e)
-             (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero 1))])
-          ;; Space is second unsigned char in `seginfo` as defined in "types.h"
+             (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))])
           (define-inline 2 $seginfo-space
             [(e)
              (bind #f (e)
-                   (build-object-ref #f 'unsigned-8 e %zero 0))])
-
+                   (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-space-disp)))])
+          (define-inline 2 $list-bits-ref
+            [(e)
+             (bind #t (e)
+                   (let ([si (make-assigned-tmp 'si)]
+                         [list-bits (make-assigned-tmp 'list-bits)]
+                         [offset (make-assigned-tmp 'offset)]
+                         [byte (make-assigned-tmp 'byte)])
+                     `(let ([,si ,(build-seginfo #f e)])
+                        (let ([,list-bits ,(%mref ,si ,(constant seginfo-list-bits-disp))])
+                          (if ,(%inline eq? ,list-bits (immediate 0))
+                              (immediate 0)
+                              (let ([,offset ,(%inline srl ,(%inline logand ,(%inline + ,e (immediate ,(fx- (constant typemod) 1)))
+                                                                     (immediate ,(fx- (constant bytes-per-segment) 1)))
+                                                       (immediate ,(constant log2-ptr-bytes)))])
+                                (let ([,byte (inline ,(make-info-load 'unsigned-8 #f) ,%load ,list-bits ,%zero ,(%inline srl ,offset (immediate 3)))])
+                                  ,(build-fix (%inline logand ,(%inline srl ,byte ,(%inline logand ,offset (immediate 7)))
+                                                       (immediate ,(constant list-bits-mask)))))))))))])
           (define-inline 2 $generation
             [(e)
              (bind #t (e)
                `(if ,(%type-check mask-fixnum type-fixnum ,e)
                     ,(%constant sfalse)
-                    ,(let ([s-e (build-maybe-seginfo e)]
+                    ,(let ([s-e (build-seginfo #t e)]
                            [si (make-assigned-tmp 'si)])
                        `(let ([,si ,s-e])
                           (if ,(%inline eq? ,si (immediate 0))

s/primdata.ss

@@ -1439,6 +1439,7 @@
   (last-pair [sig [(pair) -> ((ptr . ptr))]] [flags mifoldable discard])
   (list* [sig [(ptr) -> (ptr)] [(ptr ptr ptr ...) -> ((ptr . ptr))]] [flags unrestricted discard cp02])
   (list->fxvector [sig [(sub-list) -> (fxvector)]] [flags alloc])
+  (list-assuming-immutable? [sig [(ptr) -> (boolean)]] [flags unrestricted mifoldable discard])
   (list-copy [sig [(list) -> (list)]] [flags alloc])
   (list-head [sig [(sub-ptr sub-index) -> (list)]] [flags alloc])
   (literal-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03])
@@ -2158,6 +2159,8 @@
   ($last-new-vector-element [flags single-valued])
   ($lexical-error [flags single-valued])
   ($library-search [flags])
+  ($list-bits-ref [flags single-valued])
+  ($list-bits-set! [flags single-valued])
   ($list-length [flags single-valued])
   ($load-library [flags single-valued])
   ($locate-source [flags])
@@ -2291,6 +2294,7 @@
   ($sc-put-property! [flags single-valued])
   ($script [flags single-valued])
   ($sealed-record? [sig [(ptr rtd) -> (boolean)]] [flags pure mifoldable cptypes2]) ; first argument may be not a record
+  ($seginfo [flags single-valued])
   ($seginfo-generation [flags single-valued])
   ($seginfo-space [flags single-valued])
   ($set-code-byte! [flags single-valued])

s/prims.ss

@@ -2009,12 +2009,21 @@
 (define $maybe-seginfo
   (lambda (x)
     ($maybe-seginfo x)))
+(define $seginfo
+  (lambda (x)
+    ($seginfo x)))
 (define $seginfo-generation
   (lambda (x)
     ($seginfo-generation x)))
 (define $seginfo-space
   (lambda (x)
     ($seginfo-space x)))
+(define-who $list-bits-ref
+  (lambda (x)
+    (unless (pair? x) ($oops who "~s is not a pair" x))
+    ($list-bits-ref x)))
+(define-who $list-bits-set!
+  (foreign-procedure "(cs)list_bits_set" (ptr iptr) void))
 
 (let ()
   (define $phantom-bytevector-adjust!