add ftype-scheme-object-pointer and related foreign-pointer extensions

An ftype pointer to a Scheme object is useful to communicate the address of an bytevector or flvector (like `object->reference-address`) in the same places that ftype pointers can be used. There's a key difference between using these new pointers and constructing a pointer with the result of `object->reference-address`: GC cooperation with a Scheme-object pointer ensures that the address does not go stale. Instead, the address is extracted just after moving into a context where a collection cannot occur (e.g., a foreign call without `__collect_safe`). With Scheme-object pointers as a way to unify GCable and foreign references through the ftype interface, some further additions give the ftype layer flexiblity similar to the lower-level `foreign-ref` API, which extracts data from a reference without a declared/checked foreign representation. The `ftype-any-ref` and `ftype-any-set!` forms cover pointer access and update, and `ftype-pointer` is allowed as a ftype-name for a generic pointer type. In addition, `type-scheme-object-pointer` works as an ftype-name for a pointer to a GCable object. In the case of an `(& <ftype>)` argument or result, `(& <ftype> ftype-pointer)` can be used to accept/allocate a generic pointer record instead of a <ftype>-specific pointer record, and similarly `(& <ftype> ftype-scheme-object-pointer)`. The key changes are fairly modest, but there are many additional changes just to expand plumbing. The most tedious change is that the internal `$make-record-type` function has a new argument that can turn on GC cooperation for Scheme-object ftype pointers. Most of the rest is about making foreign-call pointer arguments and results distinguish a predicate for argument checking from the rtd used to create pointer objects.
cisco · Dec 21, 2024 · 84ac8de · 84ac8de
1 parent bf70250
commit 84ac8de
Show file tree

Hide file tree

Showing 42 changed files with 1,204 additions and 359 deletions.
diff --git a/boot/pb/equates.h b/boot/pb/equates.h
@@ -1,4 +1,4 @@
-/* equates.h for Chez Scheme Version 10.2.0-pre-release.1 */
+/* equates.h for Chez Scheme Version 10.2.0-pre-release.2 */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -1015,7 +1015,7 @@ typedef uint64_t U64;
 #define rtd_sealed 0x4
 #define sbwp (ptr)0x4E
 #define scaled_shot_1_shot_flag -0x8
-#define scheme_version 0xA020001
+#define scheme_version 0xA020002
 #define seginfo_generation_disp 0x1
 #define seginfo_list_bits_disp 0x8
 #define seginfo_space_disp 0x0

diff --git a/boot/pb/gc-ocd.inc b/boot/pb/gc-ocd.inc
@@ -576,6 +576,15 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_impure(&obj, from_g);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1258,6 +1267,15 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_indirect(obj);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1837,6 +1855,15 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest)
                 }
               }
             }
+            else if (num == Strue)
+            {
+              uptr offset = (uptr)(*((pp + 1)));
+              {
+                ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                relocate_dirty(&obj, youngest);
+                *(pp) = TO_PTR((((uptr)obj) + offset));
+              }
+            }
             else
             {
               {
@@ -2095,6 +2122,15 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g)
               }
             }
           }
+          else if (num == Strue)
+          {
+            uptr offset = (uptr)(*((pp + 1)));
+            {
+              ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+              relocate_impure(&obj, from_g);
+              *(pp) = TO_PTR((((uptr)obj) + offset));
+            }
+          }
           else
           {
             relocate_pure(&(RECORDDESCPM(rtd)));
@@ -2157,6 +2193,15 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest)
             }
           }
         }
+        else if (num == Strue)
+        {
+          uptr offset = (uptr)(*((pp + 1)));
+          {
+            ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+            relocate_dirty(&obj, youngest);
+            *(pp) = TO_PTR((((uptr)obj) + offset));
+          }
+        }
         else
         {
           {
@@ -3580,6 +3625,15 @@ static IBOOL object_directly_refers_to_self(ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  if (p == obj) return 1;
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 if (p == RECORDDESCPM(rtd)) return 1;

diff --git a/boot/pb/gc-oce.inc b/boot/pb/gc-oce.inc
@@ -696,6 +696,15 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_impure(&obj, from_g);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1381,6 +1390,15 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_indirect(obj);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1961,6 +1979,15 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest)
                 }
               }
             }
+            else if (num == Strue)
+            {
+              uptr offset = (uptr)(*((pp + 1)));
+              {
+                ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                relocate_dirty(&obj, youngest);
+                *(pp) = TO_PTR((((uptr)obj) + offset));
+              }
+            }
             else
             {
               {
@@ -2221,6 +2248,15 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g)
               }
             }
           }
+          else if (num == Strue)
+          {
+            uptr offset = (uptr)(*((pp + 1)));
+            {
+              ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+              relocate_impure(&obj, from_g);
+              *(pp) = TO_PTR((((uptr)obj) + offset));
+            }
+          }
           else
           {
             relocate_pure(&(RECORDDESCPM(rtd)));
@@ -2285,6 +2321,15 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest)
             }
           }
         }
+        else if (num == Strue)
+        {
+          uptr offset = (uptr)(*((pp + 1)));
+          {
+            ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+            relocate_dirty(&obj, youngest);
+            *(pp) = TO_PTR((((uptr)obj) + offset));
+          }
+        }
         else
         {
           {
@@ -3823,6 +3868,15 @@ static IBOOL object_directly_refers_to_self(ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  if (p == obj) return 1;
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 if (p == RECORDDESCPM(rtd)) return 1;
@@ -4151,6 +4205,19 @@ static void measure(thread_gc *tgc, ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  { /* measure */
+                    ptr r_p = obj;
+                    if (!FIXMEDIATE(r_p))
+                      push_measure(tgc, r_p);
+                  }
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 {

diff --git a/boot/pb/gc-par.inc b/boot/pb/gc-par.inc
@@ -561,6 +561,15 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_impure(&obj, from_g);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 seginfo* pm_si = SegInfo((ptr_get_segment(num)));
@@ -1262,6 +1271,15 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_indirect(obj);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1841,6 +1859,15 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest)
                 }
               }
             }
+            else if (num == Strue)
+            {
+              uptr offset = (uptr)(*((pp + 1)));
+              {
+                ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                relocate_dirty(&obj, youngest);
+                *(pp) = TO_PTR((((uptr)obj) + offset));
+              }
+            }
             else
             {
               {
@@ -2109,6 +2136,15 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g)
               }
             }
           }
+          else if (num == Strue)
+          {
+            uptr offset = (uptr)(*((pp + 1)));
+            {
+              ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+              relocate_impure(&obj, from_g);
+              *(pp) = TO_PTR((((uptr)obj) + offset));
+            }
+          }
           else
           {
             seginfo* pm_si = SegInfo((ptr_get_segment(num)));
@@ -2180,6 +2216,15 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest)
             }
           }
         }
+        else if (num == Strue)
+        {
+          uptr offset = (uptr)(*((pp + 1)));
+          {
+            ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+            relocate_dirty(&obj, youngest);
+            *(pp) = TO_PTR((((uptr)obj) + offset));
+          }
+        }
         else
         {
           {
@@ -3621,6 +3666,15 @@ static IBOOL object_directly_refers_to_self(ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  if (p == obj) return 1;
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 if (p == RECORDDESCPM(rtd)) return 1;

diff --git a/boot/pb/heapcheck.inc b/boot/pb/heapcheck.inc
@@ -43,6 +43,15 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc)
                 }
               }
             }
+            else if (num == Strue)
+            {
+              uptr offset = (uptr)(*((pp + 1)));
+              {
+                ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                check_pointer(&(obj), 0, 0, p, seg, s_in, aftergc);
+                *(pp) = TO_PTR((((uptr)obj) + offset));
+              }
+            }
             else
             {
               check_pointer(&(num), 0, 0, p, seg, s_in, aftergc);

diff --git a/boot/pb/petite.boot b/boot/pb/petite.boot
diff --git a/boot/pb/scheme.boot b/boot/pb/scheme.boot
diff --git a/boot/pb/scheme.h b/boot/pb/scheme.h
@@ -1,4 +1,4 @@
-/* scheme.h for Chez Scheme Version 10.2.0-pre-release.1 (pb) */
+/* scheme.h for Chez Scheme Version 10.2.0-pre-release.2 (pb) */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -40,7 +40,7 @@
 #endif
 
 /* Chez Scheme Version and machine type */
-#define VERSION "10.2.0-pre-release.1"
+#define VERSION "10.2.0-pre-release.2"
 #define MACHINE_TYPE "pb"
 
 /* Integer typedefs */