Switch unboxed-fields bitmask to be a Scheme integer

Requires a full rebuild!!

* libguile/struct.h (SCM_VTABLE_UNBOXED_FIELDS):
(SCM_VTABLE_FIELD_IS_UNBOXED): Use logbit? to determine if a field is
unboxed.
* module/language/cps/guile-vm/lower-primcalls.scm
(vtable-has-unboxed-fields?): Just check against SCM_INUM0.
(vtable-field-boxed?): Likewise, the bitmask is an integer.
* libguile/struct.c (set_vtable_access_fields): Set UNBOXED_FIELDS
bitmask as integer.

libguile/struct.c

@@ -128,7 +128,7 @@ set_vtable_access_fields (SCM vtable)
   size_t len, nfields;
   SCM layout;
   const char *c_layout;
-  uint32_t *unboxed_fields;
+  SCM unboxed_fields = SCM_INUM0;
 
   layout = SCM_VTABLE_LAYOUT (vtable);
   c_layout = scm_i_symbol_chars (layout);
@@ -137,25 +137,16 @@ set_vtable_access_fields (SCM vtable)
   assert (len % 2 == 0);
   nfields = len / 2;
 
-  if (nfields)
+  for (size_t field = 0; field < nfields; field++)
-    {
+    if (c_layout[field*2] == 'u')
-      size_t bitmask_size = (nfields + 31U) / 32U;
+      unboxed_fields = scm_logior (unboxed_fields,
-      unboxed_fields =
+                                   scm_ash (SCM_INUM1,
-        scm_allocate_pointerless (SCM_I_CURRENT_THREAD,
+                                            scm_from_size_t (field)));
-                                  bitmask_size * sizeof (*unboxed_fields));
-      memset (unboxed_fields, 0, bitmask_size * sizeof (*unboxed_fields));
-      for (size_t field = 0; field < nfields; field++)
-        if (c_layout[field*2] == 'u')
-          unboxed_fields[field/32U] |= 1U << (field%32U);
-    }
-  else
-    unboxed_fields = NULL;
 
   /* Record computed size of vtable's instances.  */
   SCM_SET_VTABLE_FLAGS (vtable, 0);
   SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, nfields);
-  SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_unboxed_fields,
+  SCM_STRUCT_SLOT_SET (vtable, scm_vtable_index_unboxed_fields, unboxed_fields);
-                       (uintptr_t) unboxed_fields);
 }
 
 static int

libguile/struct.h

@@ -200,8 +200,8 @@ scm_i_struct_set_raw (struct scm_struct *x, size_t idx, scm_t_bits val)
 #define SCM_VTABLE_NAME(X)              (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_name))
 #define SCM_SET_VTABLE_NAME(X,V)        (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_name, V))
 #define SCM_VTABLE_SIZE(X)              (SCM_STRUCT_DATA_REF (X, scm_vtable_index_size))
-#define SCM_VTABLE_UNBOXED_FIELDS(X)    ((uint32_t*) SCM_STRUCT_DATA_REF (X, scm_vtable_index_unboxed_fields))
+#define SCM_VTABLE_UNBOXED_FIELDS(X)    (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_unboxed_fields))
-#define SCM_VTABLE_FIELD_IS_UNBOXED(X,F) (SCM_VTABLE_UNBOXED_FIELDS (X)[(F)>>5]&(1U<<((F)&31)))
+#define SCM_VTABLE_FIELD_IS_UNBOXED(X,F) (scm_is_true (scm_logbit_p (SCM_I_MAKINUM (F), SCM_VTABLE_UNBOXED_FIELDS (X))))
 
 #define SCM_STRUCT_VTABLE(X)            (SCM_PACK (SCM_CELL_WORD_0 (X) - scm_tc3_struct))
 #define SCM_STRUCT_LAYOUT(X) 	        (SCM_VTABLE_LAYOUT (SCM_STRUCT_VTABLE (X)))

module/language/cps/guile-vm/lower-primcalls.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2023 Free Software Foundation, Inc.
+;; Copyright (C) 2023, 2025 Free Software Foundation, Inc.
 
 ;;; This library is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Lesser General Public License as published by
@@ -298,31 +298,13 @@
                                                                nfields (vtable))
   (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h
   (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields))
-  (define (check-any-unboxed cps ptr word)
-    (if (< (* word 32) nfields)
-        (with-cps cps
-          (letv idx bits)
-          (let$ checkboxed (check-any-unboxed ptr (1+ word)))
-          (letk kcheckboxed ($kargs () () ,checkboxed))
-          (letk kcheck
-                ($kargs ('bits) (bits)
-                  ($branch kt kcheckboxed src 'u64-imm-= 0 (bits))))
-          (letk kword
-                ($kargs ('idx) (idx)
-                  ($continue kcheck src
-                    ($primcall 'u32-ref 'bitmask (vtable ptr idx)))))
-          (build-term
-            ($continue kword src
-              ($primcall 'load-u64 word ()))))
-        (with-cps cps
-          (build-term ($continue kf src ($values ()))))))
   (with-cps cps
-    (letv ptr)
+    (letv fields)
-    (let$ checkboxed (check-any-unboxed ptr 0))
+    (letk kcheckboxed ($kargs ('fields) (fields)
-    (letk kcheckboxed ($kargs ('ptr) (ptr) ,checkboxed))
+                        ($branch kt kf src 'eq-constant? 0 (fields))))
     (build-term
       ($continue kcheckboxed src
-        ($primcall 'pointer-ref/immediate
+        ($primcall 'scm-ref/immediate
                    `(struct . ,vtable-offset-unboxed-fields)
                    (vtable))))))
 
@@ -342,30 +324,65 @@
       ($continue ktag src
         ($primcall 'allocate-words/immediate `(struct . ,nwords) ())))))
 
-;; precondition: vtable is vtable, idx less than vtable size
+;; precondition: vtable is vtable
 (define-branching-primcall-lowerer (vtable-field-boxed? cps kf kt src idx (vtable))
   (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h
   (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields))
+  (define (some-fields-boxed cps fields)
+    (cond
+     ((< idx 8)
+      (with-cps cps
+        (letv u64 res)
+        (letk ktest
+              ($kargs ('res) (res)
+                ($branch kf kt src 'u64-imm-= 0 (res))))
+        (letk ku64
+              ($kargs ('u64) (u64)
+                ($continue ktest src
+                  ($primcall 'ulogand/immediate (ash 1 idx) (u64)))))
+        (build-term
+          ($continue ku64 src
+            ($primcall 'scm->u64/truncate #f (fields))))))
+     ((< idx 64)
+      (with-cps cps
+        (letv pat u64 res)
+        (letk ktest
+              ($kargs ('res) (res)
+                ($branch kf kt src 'u64-imm-= 0 (res))))
+        (letk kpat
+              ($kargs ('pat) (pat)
+                ($continue ktest src
+                  ($primcall 'ulogand #f (u64 pat)))))
+        (letk ku64
+              ($kargs ('u64) (u64)
+                ($continue kpat src
+                  ($primcall 'load-u64 (ash 1 idx) ()))))
+        (build-term
+          ($continue ku64 src
+            ($primcall 'scm->u64/truncate #f (fields))))))
+     (else
+      (with-cps cps
+        (letv pat res)
+        (letk ktest
+              ($kargs ('res) (res)
+                ($branch kf kt src 'eq-constant? 0 (res))))
+        (letk kpat
+              ($kargs ('pat) (pat)
+                ($continue ktest src
+                  ($primcall 'logand #f (fields pat)))))
+        (build-term
+          ($continue kpat src ($const (ash 1 idx))))))))
   (with-cps cps
-    (letv ptr word bits res)
+    (letv fields)
-    (letk ktest
+    (let$ test (some-fields-boxed fields))
-          ($kargs ('res) (res)
+    (letk kcheck
-            ($branch kf kt src 'u64-imm-= 0 (res))))
+          ($kargs () () ,test))
-    (letk kbits
+    (letk kfields
-          ($kargs ('bits) (bits)
+          ($kargs ('fields) (fields)
-            ($continue ktest src
+            ($branch kcheck kt src 'eq-constant? 0 (fields))))
-              ($primcall 'ulogand/immediate (ash 1 (logand idx 31)) (bits)))))
-    (letk kword
-          ($kargs ('word) (word)
-            ($continue kbits src
-              ($primcall 'u32-ref 'bitmask (vtable ptr word)))))
-    (letk kptr
-          ($kargs ('ptr) (ptr)
-            ($continue kword src
-              ($primcall 'load-u64 (ash idx -5) ()))))
     (build-term
-      ($continue kptr src
+      ($continue kfields src
-        ($primcall 'pointer-ref/immediate
+        ($primcall 'scm-ref/immediate
                    `(struct . ,vtable-offset-unboxed-fields)
                    (vtable))))))