mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-02 15:40:38 +02:00
Code Activity

Remove print state objects, and ports-with-print-state

Browse source 
The goal was that, as part of a print operation, all nested prints of
contained data would be able to use the same parameters (e.g. write or
not), and also detect cycles, highlight objects, etc.  The mechanism was
a heap-allocated data structure.  However, given that:

  1. Nobody accessed print states from Scheme

  2. `write` and `display` should move to Scheme anyway, in order to be
     suspendable

  3. The "fancyp" and "highlight" options were unused

  4. A simple stack-allocated data structure with a per-thread key could
     do the trick just as well, without needing the weird freelist
     structure

  5. Ports-with-print-states were a source of bugs

In the end we switch print states to be something completely internal to
print.c.  There are no more SCM print-state objects, and no more
ports-with-print-state.

* libguile/print.h: Remove print state from API.
* libguile/print.c (struct scm_print_state): Move definition here.
(scm_print_opts): Remove "highlight-prefix" and "highlight-suffix"
options, as they were not used.
(ENTER_NESTED_DATA): Remove "fancyp" case.
(init_print_state_key, get_print_state, push_print_state)
(maybe_push_print_state, pop_print_state): New facility to manage stack
of active print states.
(scm_iprin1, print_vector): No more fancyp.
(iprin1): Access "writingp" member directly.  Don't make ports with
print states.
(scm_prin1): Manage print state stack.
(scm_iprlist): No more fancyp.
(scm_valid_oport_value_p): Remove; valid outports are SCM_OPOUTPORTP.
* libguile/backtrace.c:
* libguile/filesys.c:
* libguile/fports.c:
* libguile/goops.c:
* libguile/ioext.c:
* libguile/ports.c:
* libguile/posix.c:
* libguile/promises.c:
* libguile/socket.c:
* libguile/struct.c: Remove cases that dealt with
ports-with-print-states.
* libguile/private-options.h: Remove highlight options.
* module/ice-9/ports.scm (inherit-print-state): Deprecate.
* libguile/deprecated.c:
* libguile/deprecated.h: Add deprecation shims for print states, as far
as that is possible.
This commit is contained in:
Andy Wingo 2025-06-17 08:33:47 +02:00
parent d1b548033c
commit 3cf4ca187c
16 changed files with 181 additions and 425 deletions
Download patch file Download diff file Expand all files Collapse all files

350
libguile/print.c
View file

@ -39,8 +39,10 @@
#include "chars.h"
#include "continuations-internal.h"
#include "control.h"
#include "dynwind.h"
#include "ephemerons.h"
#include "eval.h"
#include "extensions.h"
#include "finalizers.h"
#include "filesys.h"
#include "fluids.h"
@ -111,10 +113,6 @@ static const char *iflagnames[] =
SCM_SYMBOL (sym_reader, "reader");
scm_t_option scm_print_opts[] = {
{ SCM_OPTION_SCM, "highlight-prefix", (scm_t_bits)SCM_BOOL_F_BITS,
"The string to print before highlighted values." },
{ SCM_OPTION_SCM, "highlight-suffix", (scm_t_bits)SCM_BOOL_F_BITS,
"The string to print after highlighted values." },
{ SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F_BITS,
"How to print symbols that have a colon as their first or last character. "
"The value '#f' does not quote the colons; '#t' quotes them; "
@ -145,6 +143,23 @@ SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
/* {Printing of Scheme Objects}
*/
/* State information passed around during printing.
*/
struct scm_print_state
{
struct scm_print_state *prev;
SCM port; /* The port we are writing to */
int writingp; /* Writing? */
size_t level; /* Max level */
size_t length; /* Max number of objects per level */
size_t list_offset;
size_t top; /* Top of reference stack */
size_t ceiling; /* Max size of reference stack */
SCM ref_vect; /* Stack of references used during
circular reference detection;
a vector. */
};
/* Detection of circular references.
*
* Due to other constraints in the implementation, this code has bad
@ -167,14 +182,6 @@ do \
for (i = 0; i < pstate->top; ++i) \
if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj))) \
goto label; \
if (pstate->fancyp) \
{ \
if (pstate->top - pstate->list_offset >= pstate->level) \
{ \
scm_putc ('#', port); \
return; \
} \
} \
PUSH_REF(pstate, obj); \
} while(0)
@ -186,93 +193,51 @@ do \
} \
while (0)
SCM scm_print_state_vtable = SCM_BOOL_F;
static SCM print_state_pool = SCM_EOL;
scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#ifdef GUILE_DEBUG /* Used for debugging purposes */
SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0,
(),
"Return the current-pstate -- the car of the\n"
"@code{print_state_pool}. @code{current-pstate} is only\n"
"included in @code{--enable-guile-debug} builds.")
#define FUNC_NAME s_scm_current_pstate
{
if (!scm_is_null (print_state_pool))
return SCM_CAR (print_state_pool);
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
#endif
#define PSTATE_SIZE 50L
static SCM
make_print_state (void)
static scm_i_pthread_key_t print_state_key;
static scm_i_pthread_once_t print_state_once = SCM_I_PTHREAD_ONCE_INIT;
static void
init_print_state_key (void)
{
SCM print_state = scm_make_struct_no_tail (scm_print_state_vtable, SCM_EOL);
scm_print_state *pstate = SCM_PRINT_STATE (print_state);
pstate->handle = print_state;
pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect);
pstate->highlight_objects = SCM_EOL;
return print_state;
scm_i_pthread_key_create (&print_state_key, NULL);
}
SCM
scm_make_print_state ()
static struct scm_print_state*
get_print_state (void)
{
SCM answer = SCM_BOOL_F;
/* First try to allocate a print state from the pool */
scm_i_pthread_mutex_lock (&print_state_mutex);
if (!scm_is_null (print_state_pool))
{
answer = SCM_CAR (print_state_pool);
print_state_pool = SCM_CDR (print_state_pool);
}
scm_i_pthread_mutex_unlock (&print_state_mutex);
return scm_is_false (answer) ? make_print_state () : answer;
scm_i_pthread_once (&print_state_once, init_print_state_key);
return scm_i_pthread_getspecific (print_state_key);
}
void
scm_free_print_state (SCM print_state)
static void
push_print_state (SCM port, struct scm_print_state *state,
struct scm_print_state *prev)
{
SCM handle;
scm_print_state *pstate = SCM_PRINT_STATE (print_state);
/* Cleanup before returning print state to pool.
* It is better to do it here. Doing it in scm_prin1
* would cost more since that function is called much more
* often.
*/
pstate->fancyp = 0;
pstate->revealed = 0;
pstate->highlight_objects = SCM_EOL;
scm_i_pthread_mutex_lock (&print_state_mutex);
handle = scm_cons (print_state, print_state_pool);
print_state_pool = handle;
scm_i_pthread_mutex_unlock (&print_state_mutex);
memset (state, 0, sizeof (*state));
state->prev = prev;
state->port = port;
state->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
state->ceiling = SCM_SIMPLE_VECTOR_LENGTH (state->ref_vect);
scm_i_pthread_setspecific (print_state_key, state);
}
SCM
scm_i_port_with_print_state (SCM port, SCM print_state)
static struct scm_print_state *
maybe_push_print_state (SCM port, struct scm_print_state *state)
{
if (SCM_UNBNDP (print_state))
{
if (SCM_PORT_WITH_PS_P (port))
return port;
else
print_state = scm_make_print_state ();
/* port does not need to be coerced since it doesn't have ps */
}
else
port = SCM_COERCE_OUTPORT (port);
return scm_new_double_smob (scm_tc16_port_with_ps,
SCM_UNPACK (port), SCM_UNPACK (print_state), 0);
struct scm_print_state *prev = get_print_state ();
for (struct scm_print_state *walk = prev; walk; walk = walk->prev)
if (scm_is_eq (walk->port, port))
return walk;
push_print_state (port, state, prev);
return state;
}
static void
pop_print_state (struct scm_print_state *state)
{
scm_i_pthread_setspecific (print_state_key, state->prev);
}
static void
@ -552,15 +517,7 @@ static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);
void
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
if (pstate->fancyp
&& scm_is_true (scm_memq (exp, pstate->highlight_objects)))
{
scm_display (SCM_PRINT_HIGHLIGHT_PREFIX, port);
iprin1 (exp, port, pstate);
scm_display (SCM_PRINT_HIGHLIGHT_SUFFIX, port);
}
else
iprin1 (exp, port, pstate);
iprin1 (exp, port, pstate);
}
static void
@ -569,12 +526,6 @@ print_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t),
{
long i;
long last = len - 1;
int cutp = 0;
if (pstate->fancyp && len > pstate->length)
{
last = pstate->length - 1;
cutp = 1;
}
for (i = 0; i < last; ++i)
{
scm_iprin1 (ref (v, i), port, pstate);
@ -585,8 +536,6 @@ print_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t),
/* CHECK_INTS; */
scm_iprin1 (ref (v, i), port, pstate);
}
if (cutp)
scm_puts (" ...", port);
scm_putc (')', port);
}
@ -610,7 +559,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc3_imm24:
if (SCM_CHARP (exp))
{
if (SCM_WRITINGP (pstate))
if (pstate->writingp)
write_character (SCM_CHAR (exp), port);
else
scm_c_put_char (port, SCM_CHAR (exp));
@ -634,12 +583,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
{
SCM pwps, print = pstate->writingp ? g_write : g_display;
SCM print = pstate->writingp ? g_write : g_display;
if (SCM_UNPACK (print) == 0)
goto print_struct;
pwps = scm_i_port_with_print_state (port, pstate->handle);
pstate->revealed = 1;
scm_call_2 (print, exp, pwps);
scm_call_2 (print, exp, port);
}
else
{
@ -681,7 +628,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
size_t len = scm_i_string_length (exp);
if (SCM_WRITINGP (pstate))
if (pstate->writingp)
write_string (scm_i_string_data (exp),
scm_i_is_narrow_string (exp),
len, port);
@ -820,62 +767,44 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
}
/* Print states are necessary for circular reference safe printing.
* They are also expensive to allocate. Therefore print states are
* kept in a pool so that they can be reused.
*/
static void
dynwind_pop_state (void *data)
{
scm_print_state *state = data;
pop_print_state (state);
}
/* The PORT argument can also be a print-state/port pair, which will
* then be used instead of allocating a new print state. This is
* useful for continuing a chain of print calls from Scheme. */
static void
dynwind_flip_writingp (void *data)
{
scm_print_state *state = data;
state->writingp = !state->writingp;
}
void
scm_prin1 (SCM exp, SCM port, int writingp)
{
SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */
SCM pstate_scm;
scm_print_state *pstate;
int old_writingp;
scm_print_state fresh_state;
scm_print_state *state = maybe_push_print_state (port, &fresh_state);
/* If PORT is a print-state/port pair, use that. Else create a new
print-state. */
scm_dynwind_begin (0);
if (SCM_PORT_WITH_PS_P (port))
if (state == &fresh_state)
{
pstate_scm = SCM_PORT_WITH_PS_PS (port);
port = SCM_PORT_WITH_PS_PORT (port);
state->writingp = writingp;
scm_dynwind_unwind_handler (dynwind_pop_state, state,
SCM_F_WIND_EXPLICITLY);
}
else
else if (state->writingp != writingp)
{
/* First try to allocate a print state from the pool */
scm_i_pthread_mutex_lock (&print_state_mutex);
if (!scm_is_null (print_state_pool))
{
handle = print_state_pool;
print_state_pool = SCM_CDR (print_state_pool);
}
scm_i_pthread_mutex_unlock (&print_state_mutex);
if (scm_is_false (handle))
handle = scm_list_1 (make_print_state ());
pstate_scm = SCM_CAR (handle);
dynwind_flip_writingp (state);
scm_dynwind_unwind_handler (dynwind_flip_writingp, state,
SCM_F_WIND_EXPLICITLY);
}
pstate = SCM_PRINT_STATE (pstate_scm);
old_writingp = pstate->writingp;
pstate->writingp = writingp;
scm_iprin1 (exp, port, pstate);
pstate->writingp = old_writingp;
scm_iprin1 (exp, port, state);
/* Return print state to pool if it has been created above and
hasn't escaped to Scheme. */
if (scm_is_true (handle) && !pstate->revealed)
{
scm_i_pthread_mutex_lock (&print_state_mutex);
SCM_SETCDR (handle, print_state_pool);
print_state_pool = handle;
scm_i_pthread_mutex_unlock (&print_state_mutex);
}
scm_dynwind_end ();
}
static void
@ -1012,9 +941,6 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate)
long floor = pstate->top - 2;
scm_puts (hdr, port);
/* CHECK_INTS; */
if (pstate->fancyp)
goto fancy_printing;
/* Run a hare and tortoise so that total time complexity will be
O(depth * N) instead of O(N^2). */
hare = SCM_CDR (exp);
@ -1063,21 +989,9 @@ fancy_printing:
exp = SCM_CDR (exp); --n;
for (; scm_is_pair (exp); exp = SCM_CDR (exp))
{
register unsigned long i;
for (i = 0; i < pstate->top; ++i)
for (unsigned long i = 0; i < pstate->top; ++i)
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
goto fancy_circref;
if (pstate->fancyp)
{
if (n == 0)
{
scm_puts (" ...", port);
goto skip_tail;
}
else
--n;
}
PUSH_REF(pstate, exp);
++pstate->list_offset;
scm_putc (' ', port);
@ -1090,7 +1004,6 @@ fancy_printing:
scm_puts (" . ", port);
scm_iprin1 (exp, port, pstate);
}
skip_tail:
pstate->list_offset -= pstate->top - floor - 2;
goto end;
@ -1105,14 +1018,6 @@ circref:
int
scm_valid_oport_value_p (SCM val)
{
return (SCM_OPOUTPORTP (val)
|| (SCM_PORT_WITH_PS_P (val)
&& SCM_OPOUTPORTP (SCM_PORT_WITH_PS_PORT (val))));
}
/* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */
SCM
@ -1121,7 +1026,7 @@ scm_write (SCM obj, SCM port)
if (SCM_UNBNDP (port))
port = scm_current_output_port ();
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
SCM_ASSERT (SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
scm_prin1 (obj, port, 1);
return SCM_UNSPECIFIED;
@ -1136,7 +1041,7 @@ scm_display (SCM obj, SCM port)
if (SCM_UNBNDP (port))
port = scm_current_output_port ();
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
SCM_ASSERT (SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
scm_prin1 (obj, port, 0);
return SCM_UNSPECIFIED;
@ -1166,7 +1071,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
if (scm_is_eq (destination, SCM_BOOL_T))
{
destination = port = scm_current_output_port ();
SCM_VALIDATE_OPORT_VALUE (1, destination);
SCM_VALIDATE_OPOUTPORT (1, destination);
}
else if (scm_is_false (destination))
{
@ -1176,8 +1081,8 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
}
else
{
SCM_VALIDATE_OPORT_VALUE (1, destination);
port = SCM_COERCE_OUTPORT (destination);
SCM_VALIDATE_OPOUTPORT (1, destination);
port = destination;
}
SCM_VALIDATE_STRING (2, message);
SCM_VALIDATE_REST_ARGUMENT (args);
@ -1248,9 +1153,9 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
if (SCM_UNBNDP (port))
port = scm_current_output_port ();
SCM_VALIDATE_OPORT_VALUE (1, port);
SCM_VALIDATE_OPOUTPORT (1, port);
scm_putc ('\n', SCM_COERCE_OUTPORT (port));
scm_putc ('\n', port);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -1262,8 +1167,6 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
{
if (SCM_UNBNDP (port))
port = scm_current_output_port ();
else
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_CHAR (1, chr);
SCM_VALIDATE_OPOUTPORT (2, port);
@ -1276,84 +1179,11 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
/* Call back to Scheme code to do the printing of special objects
* (like structs). SCM_PRINTER_APPLY applies PROC to EXP and a smob
* containing PORT and PSTATE. This object can be used as the port for
* display/write etc to continue the current print chain. The REVEALED
* field of PSTATE is set to true to indicate that the print state has
* escaped to Scheme and thus has to be freed by the GC.
*/
scm_t_bits scm_tc16_port_with_ps;
/* Print exactly as the port itself would */
static int
port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
{
obj = SCM_PORT_WITH_PS_PORT (obj);
return SCM_PORT_TYPE (obj)->print (obj, port, pstate);
}
SCM
scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate)
{
pstate->revealed = 1;
return scm_call_2 (proc, exp,
scm_i_port_with_print_state (port, pstate->handle));
}
SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0,
(SCM port, SCM pstate),
"Create a new port which behaves like @var{port}, but with an\n"
"included print state @var{pstate}. @var{pstate} is optional.\n"
"If @var{pstate} isn't supplied and @var{port} already has\n"
"a print state, the old print state is reused.")
#define FUNC_NAME s_scm_port_with_print_state
{
SCM_VALIDATE_OPORT_VALUE (1, port);
if (!SCM_UNBNDP (pstate))
SCM_VALIDATE_PRINTSTATE (2, pstate);
return scm_i_port_with_print_state (port, pstate);
}
#undef FUNC_NAME
SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
(SCM port),
"Return the print state of the port @var{port}. If @var{port}\n"
"has no associated print state, @code{#f} is returned.")
#define FUNC_NAME s_scm_get_print_state
{
if (SCM_PORT_WITH_PS_P (port))
return SCM_PORT_WITH_PS_PS (port);
if (SCM_OUTPUT_PORT_P (port))
return SCM_BOOL_F;
SCM_WRONG_TYPE_ARG (1, port);
}
#undef FUNC_NAME
void
scm_init_print ()
{
SCM type;
type = scm_make_vtable (scm_from_utf8_string (SCM_PRINT_STATE_LAYOUT),
SCM_BOOL_F);
scm_set_struct_vtable_name_x (type, scm_from_utf8_symbol ("print-state"));
scm_print_state_vtable = type;
/* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */
scm_tc16_port_with_ps = scm_make_smob_type (0, 0);
scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print);
#include "print.x"
scm_init_opts (scm_print_options, scm_print_opts);
scm_print_opts[SCM_PRINT_HIGHLIGHT_PREFIX_I].val =
SCM_UNPACK (scm_from_utf8_string ("{"));
scm_print_opts[SCM_PRINT_HIGHLIGHT_SUFFIX_I].val =
SCM_UNPACK (scm_from_utf8_string ("}"));
scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
}