Merge branch 'phantom' of github.com:mflatt/ChezScheme

original commit: 743a56d8f1920620e8f6e14edca7984101425e14

LOG

@@ -1062,3 +1062,8 @@
 - use the "single-valued" flag on primitives to simplify certain
   call-with-values patterns
     cp0.ss, cp0.ms
+- added phantom bytevectors
+    cmacros.ss, primdata.ss, prims.ss, cpnanopass.ss, fasl.ss,
+    inspect.ss, prin.ss, mkheader.ss, misc.ms,
+    alloc.c, prim5.c, gc.c, fasl.c, externs.h,
+    smgmt.stex, system.stex, release_notes.stex

c/alloc.c

@@ -146,6 +146,7 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; {
 
   g = gmin;
   while (g <= gmax) {
+    n += S_G.phantom_sizes[g];
     for (s = smin; s <= smax; s++) {
      /* add in bytes previously recorded */
       n += S_G.bytes_of_space[s][g];
@@ -170,7 +171,7 @@ static void maybe_fire_collector() {
   ISPC s;
   uptr bytes, fudge;
 
-  bytes = 0;
+  bytes = S_G.phantom_sizes[0];
 
   for (s = 0; s <= max_real_space; s += 1) {
    /* bytes already accounted for */
@@ -928,3 +929,33 @@ ptr S_relocation_table(n) iptr n; {
     RELOCSIZE(p) = n;
     return p;
 }
+
+ptr S_phantom_bytevector(sz) uptr sz; {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_typed_object, size_phantom, p);
+
+    PHANTOMTYPE(p) = type_phantom;
+    PHANTOMLEN(p) = 0;
+
+    S_phantom_bytevector_adjust(p, sz);
+
+    return p;
+}
+
+void S_phantom_bytevector_adjust(ph, new_sz) ptr ph; uptr new_sz; {
+  uptr old_sz = PHANTOMLEN(ph);
+  seginfo *si;
+  IGEN g;
+
+  tc_mutex_acquire()
+
+  si = SegInfo(ptr_get_segment(ph));
+  g = si->generation;
+
+  S_G.phantom_sizes[g] += (new_sz - old_sz);
+  PHANTOMLEN(ph) = new_sz;
+
+  tc_mutex_release()
+}

c/externs.h

@@ -90,6 +90,8 @@ extern ptr S_string PROTO((const char *s, iptr n));
 extern ptr S_bignum PROTO((iptr n, IBOOL sign));
 extern ptr S_code PROTO((ptr tc, iptr type, iptr n));
 extern ptr S_relocation_table PROTO((iptr n));
+extern ptr S_phantom_bytevector PROTO((uptr sz));
+extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz));
 
 /* fasl.c */
 extern void S_fasl_init PROTO((void));

c/fasl.c

@@ -937,6 +937,9 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
         case fasl_type_library_code:
             *x = CLOSCODE(S_lookup_library_entry(uptrin(f), 1));
             return;
+        case fasl_type_phantom:
+            *x = S_phantom_bytevector(uptrin(f));
+            return;
         case fasl_type_graph:
             faslin(tc, x, S_vector(uptrin(f)), pstrbuf, f);
             return;

c/gc.c

@@ -480,6 +480,11 @@ static ptr copy(pp, si) ptr pp; seginfo *si; {
 #endif /* ENABLE_OBJECT_COUNTS */
           find_room(space_data, tg, type_typed_object, size_rtd_counts, p);
           copy_ptrs(type_typed_object, p, pp, size_rtd_counts);
+      } else if (TYPEP(tf, mask_phantom, type_phantom)) {
+          find_room(space_data, tg, type_typed_object, size_phantom, p);
+          PHANTOMTYPE(p) = PHANTOMTYPE(pp);
+          PHANTOMLEN(p) = PHANTOMLEN(pp);
+          S_G.phantom_sizes[tg] += PHANTOMLEN(p);
       } else {
           S_error_abort("copy(gc): illegal type");
           return (ptr)0 /* not reached */;
@@ -691,6 +696,8 @@ static void sweep(ptr tc, ptr p, IBOOL sweep_pure) {
     sweep_thread(p);
   } else if ((iptr)tf == type_rtd_counts) {
     /* nothing to sweep */;
+  } else if ((iptr)tf == type_phantom) {
+    /* nothing to sweep */;
   } else {
     S_error_abort("sweep(gc): illegal type");
   }
@@ -913,6 +920,11 @@ void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
             S_G.bytes_of_space[s][g] = 0;
         }
 
+  /* reset phantom size in generations to be copied */
+    for (g = 0; g <= mcg; g++) {
+      S_G.phantom_sizes[g] = 0;
+    }
+
   /* set up target generation sweep_loc and orig_next_loc pointers */
     for (s = 0; s <= max_real_space; s++)
       orig_next_loc[s] = sweep_loc[s] = S_G.next_loc[s][tg];
@@ -1690,6 +1702,8 @@ static iptr size_object(p) ptr p; {
         return size_thread;
     } else if ((iptr)tf == type_rtd_counts) {
         return size_rtd_counts;
+    } else if ((iptr)tf == type_phantom) {
+        return size_phantom;
     } else {
         S_error_abort("size_object(gc): illegal type");
         return 0 /* not reached */;

c/globals.h

@@ -133,6 +133,7 @@ EXTERN struct {
     ptr static_id;
     ptr countof_names;
     ptr gcbackreference[static_generation+1];
+    uptr phantom_sizes[static_generation+1];
 
   /* intern.c */
     iptr *oblist_length_pointer;

c/prim5.c

@@ -1574,6 +1574,8 @@ void S_prim5_init() {
     Sforeign_symbol("(cs)bytevector_compress", (void*)S_bytevector_compress);
     Sforeign_symbol("(cs)bytevector_uncompress", (void*)S_bytevector_uncompress);
 
+    Sforeign_symbol("(cs)phantom_bytevector_adjust", (void*)S_phantom_bytevector_adjust);
+
     Sforeign_symbol("(cs)logand", (void *)S_logand);
     Sforeign_symbol("(cs)logbitp", (void *)S_logbitp);
     Sforeign_symbol("(cs)logbit0", (void *)S_logbit0);

csug/smgmt.stex

@@ -882,3 +882,88 @@ or objects that have been made static is unnecessary and ineffective but harmles
 This predicate returns true if \var{obj} cannot be relocated or reclaimed
 by the collector, including immediate values, such as fixnums,
 booleans, and characters, and objects that have been made static.
+
+
+\section{Phantom Bytevectors\label{SECTSMGMTPHANTOM}}
+
+\index{phamtom bytevectors}A \emph{phantom bytevector} represents
+memory that is allocated outside of the Scheme stroage management
+system. A phantom bytevector itself uses a small amount of space, but
+it contains a length that reflects external allocation. Representing
+external allocation can be useful for reflecting memory consumption
+and triggering garbage-collection heuristics based on consumption. For
+example, for a program that allocates external objects and frees
+through a guardian, representing the external object's memory use can
+trigger earlier garbage collections when the external objects are
+large. A phantom bytevector can also reflect external allocation to
+tools like \scheme{compute-size}, since the length of a phantom
+bytevector is included in the result of \scheme{compute-size} for the
+phantom bytevector.
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{make-phantom-bytevector}{\categoryprocedure}{(make-phantom-bytevector \var{n})}
+\returns a phantom bytevector
+\listlibraries
+\endentryheader
+
+\noindent
+\var{n} must be an exact nonnegative integer.
+
+Creates a phantom bytevector that reflects \var{n} bytes of external
+allocation.
+
+The value \var{n} must reflect actual allocation in the sense of
+consuming a portion of the process's address space. Claiming
+significantly more bytes than are actually allocated introduces the
+possibility of overflow within the store management system's
+calculations.
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{phantom-bytevector?}{\categoryprocedure}{(phantom-bytevector? \var{obj})}
+\returns \scheme{#t} if obj is a phantom bytevector, \scheme{#f} otherwise
+\listlibraries
+\endentryheader
+
+\schemedisplay
+(phantom-bytevector? (make-phantom-bytevector 1024)) ;=> #t
+\endschemedisplay
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{phantom-bytevector-length}{\categoryprocedure}{(phantom-bytevector-length \var{pbv})}
+\returns the length of the phantom bytevector
+\listlibraries
+\endentryheader
+
+\noindent
+\var{pbv} must be a phantom bytevector.
+
+Returns the number of bytes of external allocation that \var{pbv}
+represents.
+
+\schemedisplay
+(phantom-bytevector-length (make-phantom-bytevector 1024)) ;=> 1024
+\endschemedisplay
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{set-phantom-bytevector-length!}{\categoryprocedure}{(set-phantom-bytevector-length! \var{pbv} \var{n})}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+\noindent
+\var{pbv} must be a phantom bytevector, and \var{n} must be an exact nonnegative integer.
+
+Adjusts the allocation represented by \var{pbv} to \var{n} bytes. For
+example, when an externally allocated object represented by \var{pbv}
+is deallocated, then \var{pbv}'s length should be set to \scheme{0}.
+
+\schemedisplay
+(define pbv (make-phantom-bytevector 1024))
+(phantom-bytevector-length pbv) ;=> 1024
+(set-phantom-bytevector-length! pbv 1)
+(phantom-bytevector-length pbv) ;=> 1
+\endschemedisplay

csug/system.stex

@@ -4498,7 +4498,9 @@ See also \scheme{current-time}, which returns more precise information.
 \endentryheader
 
 If \var{g} is supplied, \scheme{bytes-allocated} returns the number of
-bytes currently allocated for Scheme objects in the specified generation.
+bytes currently allocated for Scheme objects in the specified generation
+plus externally allocated bytes as represented by phantom bytevectors in
+the generation.
 \var{g} must be a nonnegative exact integer no greater than the
 maximum nonstatic generation, i.e., the
 value returned by \scheme{collect-maximum-generation}, or the symbol
@@ -4506,7 +4508,6 @@ value returned by \scheme{collect-maximum-generation}, or the symbol
 If \var{g} is not supplied, \scheme{bytes-allocated} returns the total
 number of bytes allocated in all generations.
 
-
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{initial-bytes-allocated}{\categoryprocedure}{(initial-bytes-allocated)}
@@ -4539,7 +4540,9 @@ in bytes, including not only the bytes occupied for Scheme objects
 but also various forms of overhead, including fragmentation and
 reserved but not currently occupied memory, and is thus an accurate
 measure of the amount of heap memory currently reserved from the
-operating system for the current process.
+operating system for the current process. The result is only for
+Scheme's storage management, however, so it does not include sizes
+for externally allocated objects that are represented by phantom bytevectors.
 
 %----------------------------------------------------------------------------
 \entryheader

mats/misc.ms

@@ -5376,4 +5376,84 @@
     (expand-omit-library-invocations #f)
     (not (expand-omit-library-invocations)))
   (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m)))
-  )
+)
+
+(mat phantom-bytevector
+  (phantom-bytevector? (make-phantom-bytevector 0))
+  (not (phantom-bytevector? 10))
+  (not (phantom-bytevector? (vector 1 2 3)))
+
+  (error? (make-phantom-bytevector -1))
+  (error? (make-phantom-bytevector (expt 2 100)))
+  (error? (make-phantom-bytevector 'x))
+
+  (begin
+    (define $ph (make-phantom-bytevector 0))
+    (phantom-bytevector? $ph))
+  (eqv? 0 (phantom-bytevector-length $ph))      
+  (eqv? (void) (set-phantom-bytevector-length! $ph 1))
+  (eqv? 1 (phantom-bytevector-length $ph))
+  (eqv? (void) (set-phantom-bytevector-length! $ph 100))
+  (eqv? 100 (phantom-bytevector-length $ph))
+
+  (begin
+    (collect (collect-maximum-generation))
+    (define $pre-allocated (bytes-allocated))
+    (define $pre-memory (current-memory-bytes))
+    (set-phantom-bytevector-length! $ph $pre-allocated)
+    #t)
+
+  ;; Big change to `(bytes-allocated)`
+  (< (* 1.75 $pre-allocated)
+     (bytes-allocated)
+     (* 2.25 $pre-allocated))
+
+  ;; No big change to `(current-memory-bytes)`
+  (< (* 0.75 $pre-memory)
+     (current-memory-bytes)
+     (* 1.25 $pre-memory))
+
+  ;; Same change after GC
+  (begin
+    (collect (collect-maximum-generation))
+    (< (* 1.75 $pre-allocated)
+       (bytes-allocated)
+       (* 2.25 $pre-allocated)))
+
+  ;; fasl => another jump by `$pre-allocated` bytes
+  (begin
+    (define $ph2
+      (let-values ([(o get) (open-bytevector-output-port)])
+        (fasl-write $ph o)
+        (fasl-read (open-bytevector-input-port (get)))))
+    (phantom-bytevector? $ph2))
+
+  (< (* 2.75 $pre-allocated)
+     (bytes-allocated)
+     (* 3.25 $pre-allocated))
+
+  ;; Try GC again
+  (begin
+    (collect (collect-maximum-generation))
+    (< (* 2.75 $pre-allocated)
+       (bytes-allocated)
+       (* 3.25 $pre-allocated)))
+
+  ;; Let GC reclaim $ph2, and `(byte-allocated)` should go down
+  (begin
+    (set! $ph2 #f)
+    (collect (collect-maximum-generation))
+    (< (* 1.75 $pre-allocated)
+       (bytes-allocated)
+       (* 2.25 $pre-allocated)))
+
+  (> (compute-size $ph) (phantom-bytevector-length $ph))
+
+  ;; Change length of `$ph`, and `(byte-allocated)` should go down
+  (begin
+    (set-phantom-bytevector-length! $ph 0)
+    (< (* 0.75 $pre-allocated)
+       (bytes-allocated)
+       (* 1.25 $pre-allocated)))
+
+)

release_notes/release_notes.stex

@@ -58,6 +58,13 @@ Online versions of both books can be found at
 %-----------------------------------------------------------------------------
 \section{Functionality Changes}\label{section:functionality}
 
+\subsection{Phantom bytevectors (9.5.1)}
+
+Phantom bytevectors reflect externally allocated memory use in an
+object. A phamtom bytevector is recognized by \scheme{compute-size},
+and it can affect garbage-collection heuristics to trigger earlier
+finalization of the external object through a guardian.
+
 \subsection{Counting reachable objects from multiple sources (9.5.1)}
 
 The new procedure \scheme{compute-size-increments} is like

s/cmacros.ss

@@ -456,6 +456,7 @@
 (define-constant fasl-type-immutable-box 40)
 
 (define-constant fasl-type-begin 41)
+(define-constant fasl-type-phantom 42)
 
 (define-constant fasl-fld-ptr 0)
 (define-constant fasl-fld-u8 1)
@@ -749,6 +750,7 @@
 (define-constant type-thread           #b01001110)
 (define-constant type-tlc              #b01011110)
 (define-constant type-rtd-counts       #b01101110)
+(define-constant type-phantom          #b01111110)
 (define-constant type-record                #b111)
 
 (define-constant code-flag-system           #b0001)
@@ -932,6 +934,7 @@
            (fx- (fxsll 1 (constant code-flags-offset)) 1)))
 (define-constant mask-thread       (constant byte-constant-mask))
 (define-constant mask-tlc          (constant byte-constant-mask))
+(define-constant mask-phantom      (constant byte-constant-mask))
 
 (define-constant type-mutable-vector (constant type-vector))
 (define-constant type-immutable-vector
@@ -1467,6 +1470,10 @@
    [ptr ordered?]  ; boolean to indicate finalization mode
    [ptr pending])) ; for the GC's use
 
+(define-primitive-structure-disps phantom type-typed-object
+  ([iptr type]
+   [uptr length]))
+
 ;;; forwarding addresses are recorded with a single forward-marker
 ;;; bit pattern (a special Scheme object) followed by the forwarding
 ;;; address, a ptr to the forwarded object.

s/cpnanopass.ss

@@ -4941,6 +4941,7 @@
           (typed-object-pred immutable-fxvector? mask-mutable-fxvector type-immutable-fxvector)
           (typed-object-pred $inexactnum? mask-inexactnum type-inexactnum)
           (typed-object-pred $rtd-counts? mask-rtd-counts type-rtd-counts)
+          (typed-object-pred phantom-bytevector? mask-phantom type-phantom)
           (typed-object-pred input-port? mask-input-port type-input-port)
           (typed-object-pred output-port? mask-output-port type-output-port)
           (typed-object-pred port? mask-port type-port)
@@ -5733,6 +5734,22 @@
                  (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil))
                  (set! ,(%tc-ref guardian-entries) ,t))))])
 
+        (define-inline 3 $make-phantom-bytevector
+          [()
+           (bind #f ()
+             (bind #t ([t (%constant-alloc type-typed-object (constant size-phantom))])
+                   (%seq
+                    (set! ,(%mref ,t ,(constant phantom-type-disp))
+                          ,(%constant type-phantom))
+                    (set! ,(%mref ,t ,(constant phantom-length-disp))
+                          (immediate 0))
+                    ,t)))])
+        (define-inline 3 phantom-bytevector-length
+          [(e-ph)
+           (bind #f (e-ph)
+             (unsigned->ptr (%mref ,e-ph ,(constant phantom-length-disp))
+                            (constant ptr-bits)))])
+
         (define-inline 2 virtual-register-count
           [() `(quote ,(constant virtual-register-count))])
         (let ()

s/fasl.ss

@@ -524,6 +524,11 @@
        (put-uptr p (ash n -32))
        (put-uptr p (logand n #xFFFFFFFF)))))
 
+(define wrf-phantom
+  (lambda (x p)
+    (put-u8 p (constant fasl-type-phantom))
+    (put-uptr p (phantom-bytevector-length x))))
+
 (define wrf-graph
    (lambda (x p t a? handler)
       (let ([a (eq-hashtable-ref (table-hash t) x #f)])
@@ -572,6 +577,7 @@
          [(eq? x (void)) (wrf-immediate (constant svoid) p)]
          [(eq? x '#0=#0#) (wrf-immediate (constant black-hole) p)]
          [($rtd-counts? x) (wrf-immediate (constant sfalse) p)]
+         [(phantom-bytevector? x) (wrf-phantom x p)]
          [else ($oops 'fasl-write "invalid fasl object ~s" x)])))
 
 (module (start)

s/inspect.ss

@@ -509,6 +509,7 @@
                 [(char? x) char-dispatch-table]
                 [else empty-dispatch-table]))]
          [(tlc) tlc-dispatch-table]
+         [(phantom-bytevector) phantom-dispatch-table]
          [(ftype-struct) ftype-struct-dispatch-table]
          [(ftype-union) ftype-union-dispatch-table]
          [(ftype-array) ftype-array-dispatch-table]
@@ -1723,6 +1724,15 @@
       (name-line-display ((object) 'next) "next"))]
 ))
 
+(define phantom-dispatch-table
+ (make-dispatch-table
+
+   ["content-size"
+     "show size field"
+     (() (name-line-display ((object) 'content-size) "content-size"))]
+
+))
+
 (set! inspect
   (lambda (x)
     (let ([t (set-timer 0)])
@@ -1885,6 +1895,14 @@
         [write (p) (write x p)]
         [print (p) (pretty-print x p)]))
 
+    (define make-phantom-object
+      (make-object-maker phantom-bytevector (x)
+        [value () x]
+        [length () (phantom-bytevector-length x)]
+        [size (g) (compute-size x g)]
+        [write (p) (write x p)]
+        [print (p) (pretty-print x p)]))
+
     (define make-ftype-pointer-object
       (lambda (x)
         (define (unrecognized-ux ux)
@@ -2382,6 +2400,7 @@
           [(port? x) (make-port-object x)]
           [($unbound-object? x) (make-unbound-object x)]
           [($tlc? x) (make-tlc-object x)]
+          [(phantom-bytevector? x) (make-phantom-object x)]
           [else (make-simple-object x)])))
 
     (make-object x)))
@@ -2659,6 +2678,9 @@
                   (compute-size ($tlc-keyval x))
                   (compute-size ($tlc-next x)))]
                [($rtd-counts? x) (constant size-rtd-counts)]
+               [(phantom-bytevector? x)
+                (fx+ (constant size-tlc)
+                  (phantom-bytevector-length x))]
                [else ($oops who "missing case for ~s" x)])))
          (cond
           [single-inspect-mode?
@@ -2716,7 +2738,7 @@
       (define-counters (type-names type-counts incr!)
         pair symbol vector fxvector bytevector string box flonum bignum ratnum exactnum
         inexactnum continuation stack procedure code-object reloc-table port thread tlc
-        rtd-counts)
+        rtd-counts phantom)
       (define compute-composition!
         (lambda (x)
           (unless (or ($immediate? x)
@@ -2837,6 +2859,8 @@
              (compute-composition! ($tlc-keyval x))
              (compute-composition! ($tlc-next x))]
             [($rtd-counts? x) (incr! rtd-counts (constant size-rtd-counts))]
+            [(phantom-bytevector? x) (incr! phantom (fx+ (constant size-phantom)
+                                                         (phantom-bytevector-length x)))]
             [else ($oops who "missing case for ~s" x)])))
       ; ensure hashtables aren't counted
       (eq-hashtable-set! seen-ht seen-ht #t)
@@ -2905,7 +2929,7 @@
                                        (construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds)))
                                        (f (cdr flds))))))))]
                       [(or (fxvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x)
-                           ($inexactnum? x) ($rtd-counts? x)) 
+                           ($inexactnum? x) ($rtd-counts? x) (phantom-bytevector? x))
                        next-proc]
                       [(box? x) (construct-proc (unbox x) next-proc)]
                       [(ratnum? x) (construct-proc ($ratio-numerator x) ($ratio-denominator x) next-proc)]

s/mkheader.ss

@@ -805,6 +805,9 @@
         (definit INITTLCNEXT tlc next)
         (defset SETTLCNEXT tlc next)
 
+        (defref PHANTOMTYPE phantom type)
+        (defref PHANTOMLEN  phantom length)
+
         (defref SYMVAL symbol value)
         (defref SYMPVAL symbol pvalue)
         (defref SYMPLIST symbol plist)

s/primdata.ss

@@ -1452,6 +1452,7 @@
   (make-object-finder [sig [(procedure) (procedure ptr) (procedure ptr sub-ufixnum) -> (procedure)]] [flags alloc])
   (make-output-port [sig [(procedure string) -> (textual-output-port)]] [flags alloc])
   (make-parameter [sig [(ptr) (ptr procedure) -> (procedure)]] [flags true cp02 cp03])
+  (make-phantom-bytevector [sig [(uptr) -> (ptr)]] [flags true])
   (make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (rtd)]] [flags pure alloc cp02])
   (make-source-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
   (make-source-file-descriptor [sig [(string binary-input-port) (string binary-input-port ptr) (string binary-input-port ptr ptr) -> (sfd)]] [flags true])
@@ -1503,6 +1504,8 @@
   (path-parent [sig [(pathname) -> (pathname)]] [flags true #;cp02])
   (path-rest [sig [(pathname) -> (pathname)]] [flags true #;cp02])
   (path-root [sig [(pathname) -> (pathname)]] [flags true #;cp02])
+  (phantom-bytevector? [sig [(ptr) -> (boolean)]] [flags pure mifoldable discard])
+  (phantom-bytevector-length [sig [(ptr) -> (ptr)]] [flags true])
   (port-bol? [sig [(textual-output-port) -> (boolean)]] [flags discard])
   (port-closed? [sig [(port) -> (boolean)]] [flags discard])
   (port-file-descriptor [sig [(port) -> (ufixnum)]] [flags discard])
@@ -1581,6 +1584,7 @@
   (set-binary-port-output-index! [sig [(binary-output-port sub-index) -> (void)]] [flags true])
   (set-binary-port-output-size! [sig [(binary-output-port sub-length) -> (void)]] [flags true])
   (set-box! [sig [(box ptr) -> (void)]] [flags true])
+  (set-phantom-bytevector-length! [sig [(ptr ptr) -> (void)]] [flags true])
   (set-port-bol! [sig [(textual-output-port ptr) -> (void)]] [flags true])
   (set-port-eof! [sig [(input-port ptr) -> (void)]] [flags true])
   (set-port-input-buffer! [sig [(input-port sub-ptr) -> (void)]] [flags true])
@@ -2107,6 +2111,7 @@
   ($make-library-requirements-options [flags pure discard true])
   ($make-load-binary [flags])
   ($make-object-finder [flags])
+  ($make-phantom-bytevector [flags])
   ($make-promise [flags alloc])
   ($make-read [flags])
   ($make-recompile-condition [flags])

s/prims.ss

@@ -1785,6 +1785,7 @@
   (define-tlc-parameter $tlc-next $set-tlc-next!)
 )
 
+
 (define $generation
   (lambda (x)
     ($generation x)))
@@ -1798,6 +1799,38 @@
   (lambda (x)
     ($seginfo-space x)))
 
+(let ()
+  (define $phantom-bytevector-adjust!
+    (foreign-procedure "(cs)phantom_bytevector_adjust"
+      (scheme-object uptr)
+      void))
+  
+  (set-who! phantom-bytevector?
+    (lambda (v) (phantom-bytevector? v)))
+
+  (set-who! $make-phantom-bytevector
+    (lambda () (#3%$make-phantom-bytevector)))
+
+  (set-who! make-phantom-bytevector
+    (lambda (n)
+      (unless (and ($integer-64? n) (>= n 0))
+        ($oops who "~s is not a valid phantom bytevector length" n))
+      (let ([ph ($make-phantom-bytevector)])
+        ($phantom-bytevector-adjust! ph n)
+        ph)))
+  
+  (set-who! phantom-bytevector-length
+    (lambda (ph)
+      (unless (phantom-bytevector? ph) ($oops who "~s is not a phantom bytevector" ph))
+      (#3%phantom-bytevector-length ph)))
+  
+  (set-who! set-phantom-bytevector-length!
+    (lambda (ph n)
+      (unless (phantom-bytevector? ph) ($oops who "~s is not a phantom bytevector" ph))
+      (unless (and ($integer-64? n) (>= n 0))
+        ($oops who "~s is not a valid phantom bytevector length" n))
+      ($phantom-bytevector-adjust! ph n))))
+
 (define ($fxaddress x) (#3%$fxaddress x))
 
 (define $logand

s/print.ss

@@ -691,6 +691,7 @@ floating point returns with (1 0 -1 ...).
           [($tlc?) (display-string "#<tlc>" p)]
           [(thread?) (wrthread x p)]
           [($rtd-counts?) (display-string "#<rtd-counts>" p)]
+          [(phantom-bytevector?) (display-string "#<phantom-bytevector>" p)]
           [else (display-string "#<garbage>" p)])]
         [else (display-string "#<foreign>" p)])))