From 538def47de431548fd4c309db034274343118b54 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 19 Jan 2019 22:05:03 -0700 Subject: [PATCH] add phantom bytevectors original commit: 001917fd98ac6a0f13ccab902e15b9d2169c4b9c --- LOG | 5 ++ c/alloc.c | 33 ++++++++++++- c/externs.h | 2 + c/fasl.c | 3 ++ c/gc.c | 14 ++++++ c/globals.h | 1 + c/prim5.c | 2 + csug/smgmt.stex | 85 ++++++++++++++++++++++++++++++++ csug/system.stex | 9 ++-- mats/misc.ms | 80 ++++++++++++++++++++++++++++++ release_notes/release_notes.stex | 7 +++ s/cmacros.ss | 8 +++ s/cpnanopass.ss | 17 +++++++ s/fasl.ss | 6 +++ s/inspect.ss | 28 ++++++++++- s/mkheader.ss | 3 ++ s/primdata.ss | 5 ++ s/prims.ss | 32 ++++++++++++ s/print.ss | 1 + 19 files changed, 335 insertions(+), 6 deletions(-) diff --git a/LOG b/LOG index e5aae978a0..604b98d56c 100644 --- a/LOG +++ b/LOG @@ -1027,3 +1027,8 @@ cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms - added initialization of seginfo sorted and trigger_ephemerons fields. segment.c +- 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 diff --git a/c/alloc.c b/c/alloc.c index efdd268969..bcd7c4d312 100644 --- a/c/alloc.c +++ b/c/alloc.c @@ -130,6 +130,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]; @@ -154,7 +155,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 */ @@ -911,3 +912,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() +} diff --git a/c/externs.h b/c/externs.h index 778db3b85b..515d01f3b4 100644 --- a/c/externs.h +++ b/c/externs.h @@ -89,6 +89,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)); diff --git a/c/fasl.c b/c/fasl.c index c659c69ec2..932ee2402c 100644 --- a/c/fasl.c +++ b/c/fasl.c @@ -936,6 +936,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; diff --git a/c/gc.c b/c/gc.c index c65215d16a..51aeca1304 100644 --- a/c/gc.c +++ b/c/gc.c @@ -434,6 +434,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 */; @@ -625,6 +630,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"); } @@ -732,6 +739,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]; @@ -1395,6 +1407,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 */; diff --git a/c/globals.h b/c/globals.h index e1c29ff3cc..c97248f495 100644 --- a/c/globals.h +++ b/c/globals.h @@ -126,6 +126,7 @@ EXTERN struct { uptr countof_size[countof_types]; ptr static_id; ptr countof_names; + uptr phantom_sizes[static_generation+1]; /* intern.c */ iptr *oblist_length_pointer; diff --git a/c/prim5.c b/c/prim5.c index bb40e6277b..524311380a 100644 --- a/c/prim5.c +++ b/c/prim5.c @@ -1571,6 +1571,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); diff --git a/csug/smgmt.stex b/csug/smgmt.stex index 854129866e..cb202e3efc 100644 --- a/csug/smgmt.stex +++ b/csug/smgmt.stex @@ -860,3 +860,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 diff --git a/csug/system.stex b/csug/system.stex index 19231adccc..4114b41669 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -4355,7 +4355,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 @@ -4363,7 +4365,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)} @@ -4396,7 +4397,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 diff --git a/mats/misc.ms b/mats/misc.ms index 215e5b3c0a..fe967c4710 100644 --- a/mats/misc.ms +++ b/mats/misc.ms @@ -5051,3 +5051,83 @@ (mutable-bytevector? '#vu8()) ) + +(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))) + + ) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 289d6d1eb5..88e48e36dd 100644 --- a/release_notes/release_notes.stex +++ b/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{Procedure source location without inspector information (9.5.1)} When \scheme{generate-inspector-information} is set to \scheme{#f} and diff --git a/s/cmacros.ss b/s/cmacros.ss index bd188e982a..447c125fb9 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -455,6 +455,8 @@ (define-constant fasl-type-immutable-bytevector 39) (define-constant fasl-type-immutable-box 40) +(define-constant fasl-type-phantom 41) + (define-constant fasl-fld-ptr 0) (define-constant fasl-fld-u8 1) (define-constant fasl-fld-i16 2) @@ -745,6 +747,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) @@ -912,6 +915,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 @@ -1443,6 +1447,10 @@ [ptr tconc] [ptr next])) +(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. diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 310054441b..20847c50af 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -4745,6 +4745,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) @@ -5385,6 +5386,22 @@ (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) (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 () diff --git a/s/fasl.ss b/s/fasl.ss index be4eaefd86..238da23174 100644 --- a/s/fasl.ss +++ b/s/fasl.ss @@ -516,6 +516,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)]) @@ -564,6 +569,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)]))) (define start diff --git a/s/inspect.ss b/s/inspect.ss index bd54c87116..1edbc9f2ec 100644 --- a/s/inspect.ss +++ b/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))) @@ -2565,6 +2584,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)]))) ; ensure size-ht isn't counted in the size of any object (eq-hashtable-set! size-ht size-ht (cons cookie 0)) @@ -2596,7 +2618,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) @@ -2716,6 +2738,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) @@ -2784,7 +2808,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)] diff --git a/s/mkheader.ss b/s/mkheader.ss index e10453e9bc..49ff6d0ade 100644 --- a/s/mkheader.ss +++ b/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) diff --git a/s/primdata.ss b/s/primdata.ss index 244c957bd3..3c10312751 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1438,6 +1438,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]) @@ -1487,6 +1488,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]) @@ -1565,6 +1568,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]) @@ -2078,6 +2082,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]) diff --git a/s/prims.ss b/s/prims.ss index a56fde1174..1a613d9634 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -1721,6 +1721,38 @@ (define-tlc-parameter $tlc-next $set-tlc-next!) ) +(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 diff --git a/s/print.ss b/s/print.ss index e56e855e1e..3872677574 100644 --- a/s/print.ss +++ b/s/print.ss @@ -691,6 +691,7 @@ floating point returns with (1 0 -1 ...). [($tlc?) (display-string "#" p)] [(thread?) (wrthread x p)] [($rtd-counts?) (display-string "#" p)] + [(phantom-bytevector?) (display-string "#" p)] [else (display-string "#" p)])] [else (display-string "#" p)])))