guile/libguile/finalizers.c

/* Copyright 2012-2014,2018-2020,2022,2025
     Free Software Foundation, Inc.

   This file is part of Guile.

   Guile is free software: you can redistribute it and/or modify it
   under the terms of the GNU Lesser General Public License as published
   by the Free Software Foundation, either version 3 of the License, or
   (at your option) any later version.

   Guile is distributed in the hope that it will be useful, but WITHOUT
   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
   License for more details.

   You should have received a copy of the GNU Lesser General Public
   License along with Guile.  If not, see
   <https://www.gnu.org/licenses/>.  */




#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <assert.h>
#include <errno.h>
#include <fcntl.h>
#include <full-write.h>
#include <stdio.h>
#include <unistd.h>

#include "async.h"
#include "atomics-internal.h"
#include "continuations.h"
#include "eval.h"
#include "extensions.h"
#include "foreign.h"
#include "gc-internal.h"
#include "gsubr.h"
#include "guardians.h"
#include "init.h"
#include "numbers.h"
#include "ports.h"
#include "smob.h"
#include "struct.h"
#include "symbols.h"
#include "threads.h"
#include "version.h"

#include <gc-finalizer.h>

#include "finalizers.h"




static int automatic_finalization_p = 1;

static size_t finalization_count;

static SCM run_finalizers_subr;




enum finalizer_priority
  {
    FINALIZER_PRIORITY_GUARDIAN,
    FINALIZER_PRIORITY_DEFAULT
  };

enum builtin_finalizer_kind
  {
    FINALIZE_KIND_STRUCT,
    FINALIZE_KIND_SMOB,
    FINALIZE_KIND_PORT,
  };

static inline SCM ref_to_scm (struct gc_ref ref)
{
  return SCM_PACK (gc_ref_value (ref));
}
static inline struct gc_ref scm_to_ref (SCM scm)
{
  return gc_ref (SCM_UNPACK (scm));
}

static SCM
add_finalizer (struct scm_thread *thread, SCM obj, SCM closure,
               enum finalizer_priority priority)
{
  struct gc_finalizer *finalizer = gc_allocate_finalizer (thread->mutator);
  SCM ret = SCM_PACK_POINTER (finalizer);
  SCM_SET_CELL_WORD_0 (ret, scm_tc7_finalizer);
  gc_finalizer_attach (thread->mutator, finalizer, priority,
                       scm_to_ref (obj), scm_to_ref (closure));
  return ret;
}

static SCM
add_builtin_finalizer (struct scm_thread *thread, SCM obj,
                       enum builtin_finalizer_kind kind)
{
  return add_finalizer (thread, obj, SCM_I_MAKINUM (kind),
                        FINALIZER_PRIORITY_DEFAULT);
}

SCM
scm_i_add_struct_finalizer (struct scm_thread *thread, SCM obj)
{
  if (!SCM_STRUCTP (obj))
    abort ();

  return add_builtin_finalizer (thread, obj, FINALIZE_KIND_STRUCT);
}

SCM
scm_i_add_smob_finalizer (struct scm_thread *thread, SCM obj)
{
  if (!SCM_HAS_TYP7 (obj, scm_tc7_smob))
    abort ();

  return add_builtin_finalizer (thread, obj, FINALIZE_KIND_SMOB);
}

SCM
scm_i_add_port_finalizer (struct scm_thread *thread, SCM obj)
{
  if (!SCM_PORTP (obj))
    abort ();

  return add_builtin_finalizer (thread, obj, FINALIZE_KIND_PORT);
}

SCM
scm_i_add_pointer_finalizer (struct scm_thread *thread, SCM obj, SCM free)
{
  if (!SCM_POINTER_P (obj))
    abort ();
  if (!SCM_POINTER_P (free))
    abort ();

  return add_finalizer (thread, obj, free, FINALIZER_PRIORITY_DEFAULT);
}

SCM
scm_i_add_finalizer (struct scm_thread *thread, SCM obj, SCM proc)
{
  if (!scm_is_true (scm_procedure_p (proc)))
    abort ();

  return add_finalizer (thread, obj, proc, FINALIZER_PRIORITY_DEFAULT);
}

SCM
scm_i_add_guardian_finalizer (struct scm_thread *thread, SCM obj, SCM guardian)
{
  if (!scm_is_true (scm_procedure_p (guardian)))
    abort ();

  return add_finalizer (thread, obj, guardian, FINALIZER_PRIORITY_GUARDIAN);
}

/* In future, we can add methods on the finalizer to retrieve the
   object, cancel the finalizer, etc.  */

static void
run_finalizer (struct scm_thread *thread, SCM obj, SCM closure)
{
  if (SCM_I_INUMP (closure))
    {
      switch (SCM_I_INUM (closure))
        {
        case FINALIZE_KIND_STRUCT:
          scm_i_finalize_struct (thread, obj);
          break;
        case FINALIZE_KIND_SMOB:
          scm_i_finalize_smob (thread, obj);
          break;
        case FINALIZE_KIND_PORT:
          scm_i_finalize_port (thread, obj);
          break;
        default:
          abort ();
        }
    }
  else if (SCM_POINTER_P (closure))
    {
      if (!SCM_POINTER_P (obj))
        abort ();
      void (*free)(void*) = SCM_POINTER_VALUE (closure);
      free (SCM_POINTER_VALUE (obj));
    }
  else
    scm_call_1 (closure, obj);
}

struct run_finalizers_data {
  scm_thread *thread;
  SCM error_port;
  int count;
  int success;
};

static void*
run_finalizers (void *raw_data)
{
  struct run_finalizers_data *data = raw_data;
  struct scm_thread *thread = data->thread;
  struct gc_mutator *mut = thread->mutator;
  for (struct gc_finalizer *finalizer = gc_pop_finalizable (mut);
       finalizer;
       finalizer = gc_pop_finalizable (mut), data->count++)
    run_finalizer (thread,
                   ref_to_scm (gc_finalizer_object (finalizer)),
                   ref_to_scm (gc_finalizer_closure (finalizer)));
  data->success = 1;
  return NULL;
}

int
scm_run_finalizers (void)
{
  struct run_finalizers_data data = {
    .thread = SCM_I_CURRENT_THREAD,
    .error_port = scm_current_error_port (),
    .count = 0,
    .success = 0
  };
  do
    scm_c_with_continuation_barrier (run_finalizers, &data);
  while (!data.success);
  finalization_count += data.count;
  return data.count;
}

SCM_DEFINE_STATIC(scm_sys_add_finalizer, "%add-finalizer!", 3, 0, 0,
                  (SCM obj, SCM proc, SCM priority),
                  "Add a finalizer @var{proc} to object @var{obj}, with "
                  "priority @var{priority}.  Return the finalizer object.")
#define FUNC_NAME s_scm_sys_add_finalizer
{
  SCM_MAKE_VALIDATE (1, obj, HEAP_OBJECT_P);
  SCM_VALIDATE_PROC (2, proc);
  size_t c_priority = scm_to_unsigned_integer (priority,
                                               FINALIZER_PRIORITY_GUARDIAN,
                                               FINALIZER_PRIORITY_DEFAULT);

  return add_finalizer (SCM_I_CURRENT_THREAD, obj, proc, c_priority);
}
#undef FUNC_NAME



static SCM
run_finalizers_async_thunk (void)
{
  scm_run_finalizers ();
  return SCM_UNSPECIFIED;
}


/* The function queue_finalizer_async is run by the GC when there are
 * objects to finalize.  It will enqueue an asynchronous call to
 * scm_run_finalizers() at the next SCM_TICK in this thread.
 */
static void
queue_finalizer_async (struct gc_heap *heap, size_t count) SCM_UNUSED;
static void
queue_finalizer_async (struct gc_heap *heap, size_t count)
{
  scm_thread *t = SCM_I_CURRENT_THREAD;
  scm_system_async_mark_for_thread (run_finalizers_subr, scm_thread_handle (t));
}




#if SCM_USE_PTHREAD_THREADS

static int finalization_pipe[2] = { -1, -1 };
static scm_i_pthread_mutex_t finalization_thread_lock =
  SCM_I_PTHREAD_MUTEX_INITIALIZER;
static pthread_t finalization_thread;
static int finalization_thread_is_running = 0;

static void
notify_finalizers_to_run (struct gc_heap *heap, size_t count)
{
  char byte = 0;
  full_write (finalization_pipe[1], &byte, 1);
}

static void
notify_about_to_fork (void)
{
  char byte = 1;
  full_write (finalization_pipe[1], &byte, 1);
}

static void
reset_finalization_pipe (void)
{
  close (finalization_pipe[0]);
  close (finalization_pipe[1]);
  finalization_pipe[0] = -1;
  finalization_pipe[1] = -1;
}

struct finalization_pipe_data
{
  char byte;
  ssize_t n;
  int err;
};

static void*
read_finalization_pipe_data (void *data)
{
  struct finalization_pipe_data *fdata = data;
  
  fdata->n = read (finalization_pipe[0], &fdata->byte, 1);
  fdata->err = errno;

  return NULL;
}

static scm_i_pthread_t finalizer_thread;

static void*
finalization_thread_proc (void *unused)
{
  scm_atomic_set_pointer ((void **) &finalizer_thread,
                          (void *) pthread_self ());
  while (1)
    {
      struct finalization_pipe_data data;

      scm_without_guile (read_finalization_pipe_data, &data);

      if (data.n == 0)
        /* The other end of the pipe was closed, so exit.  */
        return NULL;
      else if (data.n < 0)
        {
          if (data.err != EINTR)
            {
              errno = data.err;
              perror ("error in finalization thread");
              return NULL;
            }
        }
      else
        {
          switch (data.byte)
            {
            case 0:
              scm_run_finalizers ();
              break;
            case 1:
              return NULL;
            default:
              abort ();
            }
        }
    }
}

int
scm_i_is_finalizer_thread (struct scm_thread *t)
{
  scm_i_pthread_t us =
    (scm_i_pthread_t) scm_atomic_ref_pointer ((void **) &finalizer_thread);
  return pthread_equal (t->pthread, us);
}

static void*
run_finalization_thread (void *arg)
{
  void *res = scm_with_guile (finalization_thread_proc, arg);
  scm_atomic_set_pointer ((void **) &finalizer_thread, NULL);
  return res;
}

static void
start_finalization_thread (struct gc_heap *heap)
{
  scm_i_pthread_mutex_lock (&finalization_thread_lock);
  if (!finalization_thread_is_running)
    {
      assert (finalization_pipe[0] == -1);

      /* Use the raw pthread API and scm_with_guile, because we don't want
	 to block on any lock that scm_spawn_thread might want to take,
	 and we don't want to inherit the dynamic state (fluids) of the
	 caller.  */
      if (pipe2 (finalization_pipe, O_CLOEXEC) != 0)
	perror ("error creating finalization pipe");
      else if (pthread_create (&finalization_thread, NULL,
			       run_finalization_thread, NULL))
	{
	  reset_finalization_pipe ();
	  perror ("error creating finalization thread");
	}
      else
	{
	  gc_set_finalizer_callback (heap, notify_finalizers_to_run);
	  finalization_thread_is_running = 1;
	}
    }
  scm_i_pthread_mutex_unlock (&finalization_thread_lock);
}

static void
stop_finalization_thread (void)
{
  scm_i_pthread_mutex_lock (&finalization_thread_lock);
  if (finalization_thread_is_running)
    {
      notify_about_to_fork ();
      if (pthread_join (finalization_thread, NULL))
        perror ("joining finalization thread");

      reset_finalization_pipe ();
      finalization_thread_is_running = 0;
    }
  scm_i_pthread_mutex_unlock (&finalization_thread_lock);
}

static void
spawn_finalizer_thread (struct gc_heap *heap, size_t count)
{
  start_finalization_thread (heap);
}

#else /* !SCM_USE_PTHREAD_THREADS */

int
scm_i_is_finalizer_thread (struct scm_thread *t)
{
  return 0;
}

#endif /* !SCM_USE_PTHREAD_THREADS */




void
scm_i_finalizer_pre_fork (void)
{
#if SCM_USE_PTHREAD_THREADS
  if (automatic_finalization_p)
    {
      stop_finalization_thread ();
      gc_set_finalizer_callback (the_gc_heap, spawn_finalizer_thread);
    }
#endif
}




int
scm_set_automatic_finalization_enabled (int enabled_p)
{
  int was_enabled_p = automatic_finalization_p;

  if (enabled_p == was_enabled_p)
    return was_enabled_p;

  if (!scm_initialized_p)
    {
      automatic_finalization_p = enabled_p;
      return was_enabled_p;
    }

  if (enabled_p)
    {
#if SCM_USE_PTHREAD_THREADS
      gc_set_finalizer_callback (the_gc_heap, spawn_finalizer_thread);
#else
      gc_set_finalizer_callback (the_gc_heap, queue_finalizer_async);
#endif
    }
  else
    {
      gc_set_finalizer_callback (the_gc_heap, NULL);

#if SCM_USE_PTHREAD_THREADS
      stop_finalization_thread ();
#endif
    }

  automatic_finalization_p = enabled_p;

  return was_enabled_p;
}

int
scm_i_print_finalizer (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#<finalizer ", port);
  scm_uintprint (SCM_UNPACK (exp), 16, port);
  scm_puts (")>", port);
  return 1;
}




static void scm_init_finalizers_module (void);

void
scm_register_finalizers (void)
{
  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                            "scm_init_finalizers_module",
                            (scm_t_extension_init_func)scm_init_finalizers_module,
                            NULL);
}

static void
scm_init_finalizers_module (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "finalizers.x"
#endif
}

void
scm_init_finalizers (void)
{
  /* When the async is to run, the cdr of the pair gets set to the
     asyncs queue of the current thread.  */
  run_finalizers_subr = scm_c_make_gsubr ("%run-finalizers", 0, 0, 0,
                                          run_finalizers_async_thunk);

  if (automatic_finalization_p)
    {
#if SCM_USE_PTHREAD_THREADS
      gc_set_finalizer_callback (the_gc_heap, spawn_finalizer_thread);
#else
      gc_set_finalizer_callback (the_gc_heap, queue_finalizer_async);
#endif
    }

  scm_run_finalizers ();
}