code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#define _LARGEFILE64_SOURCE      /* ask for stat64 etc */

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

#include <stdio.h>
#include <fcntl.h>
#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/gc.h"
#include "libguile/posix.h"
#include "libguile/dynwind.h"

#include "libguile/fports.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_IO_H
#include <io.h>
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
#include <sys/stat.h>
#endif

#include <errno.h>
#include <sys/types.h>

#include "libguile/iselect.h"

/* Some defines for Windows (native port, not Cygwin). */
#ifdef __MINGW32__
# include <sys/stat.h>
# include <winsock2.h>
#endif /* __MINGW32__ */

/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
   already, but have this code here in case that wasn't so in past versions,
   or perhaps to help other minimal DOS environments.

   gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
   might be possibilities if we've got other systems without ftruncate.  */

#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
# define ftruncate(fd, size) chsize (fd, size)
#undef HAVE_FTRUNCATE
#define HAVE_FTRUNCATE 1
#endif

#if SIZEOF_OFF_T == SIZEOF_INT
#define OFF_T_MAX  INT_MAX
#define OFF_T_MIN  INT_MIN
#elif SIZEOF_OFF_T == SIZEOF_LONG
#define OFF_T_MAX  LONG_MAX
#define OFF_T_MIN  LONG_MIN
#elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
#define OFF_T_MAX  LONG_LONG_MAX
#define OFF_T_MIN  LONG_LONG_MIN
#else
#error Oops, unknown OFF_T size
#endif

scm_t_bits scm_tc16_fport;

/* default buffer size, used if the O/S won't supply a value.  */
static const size_t default_buffer_size = 1024;

/* create FPORT buffer with specified sizes (or -1 to use default size or
   0 for no buffer.  */
static void
scm_fport_buffer_add (SCM port, long read_size, int write_size)
#define FUNC_NAME "scm_fport_buffer_add"
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (read_size == -1 || write_size == -1)
    {
      size_t default_size;
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
      struct stat st;
      scm_t_fport *fp = SCM_FSTREAM (port);

      default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
	: st.st_blksize;
#else
      default_size = default_buffer_size;
#endif
      if (read_size == -1)
	read_size = default_size;
      if (write_size == -1)
	write_size = default_size;
    }

  if (SCM_INPUT_PORT_P (port) && read_size > 0)
    {
      pt->read_buf = scm_gc_malloc (read_size, "port buffer");
      pt->read_pos = pt->read_end = pt->read_buf;
      pt->read_buf_size = read_size;
    }
  else
    {
      pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
      pt->read_buf_size = 1;
    }

  if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
    {
      pt->write_buf = scm_gc_malloc (write_size, "port buffer");
      pt->write_pos = pt->write_buf;
      pt->write_buf_size = write_size;
    }
  else
    {
      pt->write_buf = pt->write_pos = &pt->shortbuf;
      pt->write_buf_size = 1;
    }

  pt->write_end = pt->write_buf + pt->write_buf_size;
  if (read_size > 0 || write_size > 0)
    SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
  else
    SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
            (SCM port, SCM mode, SCM size),
	    "Set the buffering mode for @var{port}.  @var{mode} can be:\n"
	    "@table @code\n"
	    "@item _IONBF\n"
	    "non-buffered\n"
	    "@item _IOLBF\n"
	    "line buffered\n"
	    "@item _IOFBF\n"
	    "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
	    "If @var{size} is omitted, a default size will be used.\n"
	    "@end table")
#define FUNC_NAME s_scm_setvbuf
{
  int cmode;
  long csize;
  scm_t_port *pt;

  port = SCM_COERCE_OUTPORT (port);

  SCM_VALIDATE_OPFPORT (1,port);
  cmode = scm_to_int (mode);
  if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
    scm_out_of_range (FUNC_NAME, mode);

  if (cmode == _IOLBF)
    {
      SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE);
      cmode = _IOFBF;
    }
  else
    {
      SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~(scm_t_bits)SCM_BUFLINE);
    }

  if (SCM_UNBNDP (size))
    {
      if (cmode == _IOFBF)
	csize = -1;
      else
	csize = 0;
    }
  else
    {
      csize = scm_to_int (size);
      if (csize < 0 || (cmode == _IONBF && csize > 0))
	scm_out_of_range (FUNC_NAME, size);
    }

  pt = SCM_PTAB_ENTRY (port);

  /* silently discards buffered and put-back chars.  */
  if (pt->read_buf == pt->putback_buf)
    {
      pt->read_buf = pt->saved_read_buf;
      pt->read_pos = pt->saved_read_pos;
      pt->read_end = pt->saved_read_end;
      pt->read_buf_size = pt->saved_read_buf_size;
    }
  if (pt->read_buf != &pt->shortbuf)
    scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
  if (pt->write_buf != &pt->shortbuf)
    scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");

  scm_fport_buffer_add (port, csize, csize);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Move ports with the specified file descriptor to new descriptors,
 * resetting the revealed count to 0.
 */

void
scm_evict_ports (int fd)
{
  long i;

  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);

  for (i = 0; i < scm_i_port_table_size; i++)
    {
      SCM port = scm_i_port_table[i]->port;

      if (SCM_FPORTP (port))
	{
	  scm_t_fport *fp = SCM_FSTREAM (port);

	  if (fp->fdes == fd)
	    {
	      fp->fdes = dup (fd);
	      if (fp->fdes == -1)
		scm_syserror ("scm_evict_ports");
	      scm_set_port_revealed_x (port, scm_from_int (0));
	    }
	}
    }

  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
}

SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
	    (SCM obj),
	    "Determine whether @var{obj} is a port that is related to a file.")
#define FUNC_NAME s_scm_file_port_p
{
  return scm_from_bool (SCM_FPORTP (obj));
}
#undef FUNC_NAME

/* scm_open_file
 * Return a new port open on a given file.
 *
 * The mode string must match the pattern: [rwa+]** which
 * is interpreted in the usual unix way.
 *
 * Return the new port.
 */
SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
           (SCM filename, SCM mode),
	    "Open the file whose name is @var{filename}, and return a port\n"
	    "representing that file.  The attributes of the port are\n"
	    "determined by the @var{mode} string.  The way in which this is\n"
	    "interpreted is similar to C stdio.  The first character must be\n"
	    "one of the following:\n"
	    "@table @samp\n"
	    "@item r\n"
	    "Open an existing file for input.\n"
	    "@item w\n"
	    "Open a file for output, creating it if it doesn't already exist\n"
	    "or removing its contents if it does.\n"
	    "@item a\n"
	    "Open a file for output, creating it if it doesn't already\n"
	    "exist.  All writes to the port will go to the end of the file.\n"
	    "The \"append mode\" can be turned off while the port is in use\n"
	    "@pxref{Ports and File Descriptors, fcntl}\n"
	    "@end table\n"
	    "The following additional characters can be appended:\n"
	    "@table @samp\n"
	    "@item b\n"
	    "Open the underlying file in binary mode, if supported by the operating system. "
	    "@item +\n"
	    "Open the port for both input and output.  E.g., @code{r+}: open\n"
	    "an existing file for both input and output.\n"
	    "@item 0\n"
	    "Create an \"unbuffered\" port.  In this case input and output\n"
	    "operations are passed directly to the underlying port\n"
	    "implementation without additional buffering.  This is likely to\n"
	    "slow down I/O operations.  The buffering mode can be changed\n"
	    "while a port is in use @pxref{Ports and File Descriptors,\n"
	    "setvbuf}\n"
	    "@item l\n"
	    "Add line-buffering to the port.  The port output buffer will be\n"
	    "automatically flushed whenever a newline character is written.\n"
	    "@end table\n"
	    "In theory we could create read/write ports which were buffered\n"
	    "in one direction only.  However this isn't included in the\n"
	    "current interfaces.  If a file cannot be opened with the access\n"
	    "requested, @code{open-file} throws an exception.")
#define FUNC_NAME s_scm_open_file
{
  SCM port;
  int fdes;
  int flags = 0;
  char *file;
  char *md;
  char *ptr;

  scm_dynwind_begin (0);

  file = scm_to_locale_string (filename);
  scm_dynwind_free (file);

  md = scm_to_locale_string (mode);
  scm_dynwind_free (md);

  switch (*md)
    {
    case 'r':
      flags |= O_RDONLY;
      break;
    case 'w':
      flags |= O_WRONLY | O_CREAT | O_TRUNC;
      break;
    case 'a':
      flags |= O_WRONLY | O_CREAT | O_APPEND;
      break;
    default:
      scm_out_of_range (FUNC_NAME, mode);
    }
  ptr = md + 1;
  while (*ptr != '\0')
    {
      switch (*ptr)
	{
	case '+':
	  flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
	  break;
	case 'b':
#if defined (O_BINARY)
	  flags |= O_BINARY;
#endif
	  break;
	case '0':  /* unbuffered: handled later.  */
	case 'l':  /* line buffered: handled during output.  */
	  break;
	default:
	  scm_out_of_range (FUNC_NAME, mode);
	}
      ptr++;
    }
  SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
  if (fdes == -1)
    {
      int en = errno;

      SCM_SYSERROR_MSG ("~A: ~S",
			scm_cons (scm_strerror (scm_from_int (en)),
				  scm_cons (filename, SCM_EOL)), en);
    }
  port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), filename);

  scm_dynwind_end ();

  return port;
}
#undef FUNC_NAME

#ifdef __MINGW32__
/*
 * Try getting the appropiate file flags for a given file descriptor
 * under Windows. This incorporates some fancy operations because Windows
 * differentiates between file, pipe and socket descriptors.
 */
#ifndef O_ACCMODE
# define O_ACCMODE 0x0003
#endif

static int getflags (int fdes)
{
  int flags = 0;
  struct stat buf;
  int error, optlen = sizeof (int);

  /* Is this a socket ? */
  if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
    flags = O_RDWR;
  /* Maybe a regular file ? */
  else if (fstat (fdes, &buf) < 0)
    flags = -1;
  else
    {
      /* Or an anonymous pipe handle ? */
      if (buf.st_mode & _S_IFIFO)
	flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0,
			       NULL, NULL, NULL) ? O_RDONLY : O_WRONLY;
      /* stdin ? */
      else if (fdes == fileno (stdin) && isatty (fdes))
	flags = O_RDONLY;
      /* stdout / stderr ? */
      else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) &&
	       isatty (fdes))
	flags = O_WRONLY;
      else
	flags = buf.st_mode;
    }
  return flags;
}
#endif /* __MINGW32__ */

/* Building Guile ports from a file descriptor.  */

/* Build a Scheme port from an open file descriptor `fdes'.
   MODE indicates whether FILE is open for reading or writing; it uses
      the same notation as open-file's second argument.
   NAME is a string to be used as the port's filename.
*/
SCM
scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
#define FUNC_NAME "scm_fdes_to_port"
{
  SCM port;
  scm_t_port *pt;
  int flags;

  /* test that fdes is valid.  */
#ifdef __MINGW32__
  flags = getflags (fdes);
#else
  flags = fcntl (fdes, F_GETFL, 0);
#endif
  if (flags == -1)
    SCM_SYSERROR;
  flags &= O_ACCMODE;
  if (flags != O_RDWR
      && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
	  || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
    {
      SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
    }

  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);

  port = scm_new_port_table_entry (scm_tc16_fport);
  SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
  pt = SCM_PTAB_ENTRY(port);
  {
    scm_t_fport *fp
      = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port");

    fp->fdes = fdes;
    pt->rw_random = SCM_FDES_RANDOM_P (fdes);
    SCM_SETSTREAM (port, fp);
    if (mode_bits & SCM_BUF0)
      scm_fport_buffer_add (port, 0, 0);
    else
      scm_fport_buffer_add (port, -1, -1);
  }
  SCM_SET_FILENAME (port, name);
  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
  return port;
}
#undef FUNC_NAME

SCM
scm_fdes_to_port (int fdes, char *mode, SCM name)
{
  return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
}

/* Return a lower bound on the number of bytes available for input.  */
static int
fport_input_waiting (SCM port)
{
#ifdef HAVE_SELECT
  int fdes = SCM_FSTREAM (port)->fdes;
  struct timeval timeout;
  SELECT_TYPE read_set;
  SELECT_TYPE write_set;
  SELECT_TYPE except_set;

  FD_ZERO (&read_set);
  FD_ZERO (&write_set);
  FD_ZERO (&except_set);

  FD_SET (fdes, &read_set);

  timeout.tv_sec = 0;
  timeout.tv_usec = 0;

  if (select (SELECT_SET_SIZE,
	      &read_set, &write_set, &except_set, &timeout)
      < 0)
    scm_syserror ("fport_input_waiting");
  return FD_ISSET (fdes, &read_set) ? 1 : 0;

#elif HAVE_IOCTL && defined (FIONREAD)
  /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
     (for use with winsock ioctlsocket()) but not ioctl().  */
  int fdes = SCM_FSTREAM (port)->fdes;
  int remir;
  ioctl(fdes, FIONREAD, &remir);
  return remir;

#else
  scm_misc_error ("fport_input_waiting",
		  "Not fully implemented on this platform",
		  SCM_EOL);
#endif
}

static int
fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#<", port);
  scm_print_port_mode (exp, port);
  if (SCM_OPFPORTP (exp))
    {
      int fdes;
      SCM name = SCM_FILENAME (exp);
      if (scm_is_string (name) || scm_is_symbol (name))
	scm_display (name, port);
      else
	scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
      scm_putc (' ', port);
      fdes = (SCM_FSTREAM (exp))->fdes;

#ifdef HAVE_TTYNAME
      if (isatty (fdes))
	scm_display (scm_ttyname (exp), port);
      else
#endif /* HAVE_TTYNAME */
	scm_intprint (fdes, 10, port);
    }
  else
    {
      scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
      scm_putc (' ', port);
      scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
    }
  scm_putc ('>', port);
  return 1;
}

#ifndef __MINGW32__
/* thread-local block for input on fport's fdes.  */
static void
fport_wait_for_input (SCM port)
{
  int fdes = SCM_FSTREAM (port)->fdes;

  if (!fport_input_waiting (port))
    {
      int n;
      SELECT_TYPE readfds;
      int flags = fcntl (fdes, F_GETFL);

      if (flags == -1)
	scm_syserror ("scm_fdes_wait_for_input");
      if (!(flags & O_NONBLOCK))
	do
	  {
	    FD_ZERO (&readfds);
	    FD_SET (fdes, &readfds);
	    n = scm_std_select (fdes + 1, &readfds, NULL, NULL, NULL);
	  }
	while (n == -1 && errno == EINTR);
    }
}
#endif /* !__MINGW32__ */

static void fport_flush (SCM port);

/* fill a port's read-buffer with a single read.  returns the first
   char or EOF if end of file.  */
static int
fport_fill_input (SCM port)
{
  long count;
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  scm_t_fport *fp = SCM_FSTREAM (port);

#ifndef __MINGW32__
  fport_wait_for_input (port);
#endif /* !__MINGW32__ */
  SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
  if (count == -1)
    scm_syserror ("fport_fill_input");
  if (count == 0)
    return EOF;
  else
    {
      pt->read_pos = pt->read_buf;
      pt->read_end = pt->read_buf + count;
      return *pt->read_buf;
    }
}

static off_t_or_off64_t
fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  scm_t_fport *fp = SCM_FSTREAM (port);
  off_t_or_off64_t rv;
  off_t_or_off64_t result;

  if (pt->rw_active == SCM_PORT_WRITE)
    {
      if (offset != 0 || whence != SEEK_CUR)
	{
	  fport_flush (port);
	  result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
	}
      else
	{
	  /* read current position without disturbing the buffer.  */
	  rv = lseek_or_lseek64 (fp->fdes, offset, whence);
	  result = rv + (pt->write_pos - pt->write_buf);
	}
    }
  else if (pt->rw_active == SCM_PORT_READ)
    {
      if (offset != 0 || whence != SEEK_CUR)
	{
	  /* could expand to avoid a second seek.  */
	  scm_end_input (port);
	  result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
	}
      else
	{
	  /* read current position without disturbing the buffer
	     (particularly the unread-char buffer).  */
	  rv = lseek_or_lseek64 (fp->fdes, offset, whence);
	  result = rv - (pt->read_end - pt->read_pos);

	  if (pt->read_buf == pt->putback_buf)
	    result -= pt->saved_read_end - pt->saved_read_pos;
	}
    }
  else /* SCM_PORT_NEITHER */
    {
      result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
    }

  if (rv == -1)
    scm_syserror ("fport_seek");

  return result;
}

/* If we've got largefile and off_t isn't already off64_t then
   fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
   the port descriptor.

   Otherwise if no largefile, or off_t is the same as off64_t (which is the
   case on NetBSD apparently), then fport_seek_or_seek64 is right to be
   fport_seek already.  */

#if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
static off_t
fport_seek (SCM port, off_t offset, int whence)
{
  off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence);
  if (rv > OFF_T_MAX || rv < OFF_T_MIN)
    {
      errno = EOVERFLOW;
      scm_syserror ("fport_seek");
    }
  return (off_t) rv;

}
#else
#define fport_seek   fport_seek_or_seek64
#endif

/* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
SCM
scm_i_fport_seek (SCM port, SCM offset, int how)
{
  return scm_from_off_t_or_off64_t
    (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how));
}

static void
fport_truncate (SCM port, off_t length)
{
  scm_t_fport *fp = SCM_FSTREAM (port);

  if (ftruncate (fp->fdes, length) == -1)
    scm_syserror ("ftruncate");
}

int
scm_i_fport_truncate (SCM port, SCM length)
{
  scm_t_fport *fp = SCM_FSTREAM (port);
  return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length));
}

/* helper for fport_write: try to write data, using multiple system
   calls if required.  */
#define FUNC_NAME "write_all"
static void write_all (SCM port, const void *data, size_t remaining)
{
  int fdes = SCM_FSTREAM (port)->fdes;

  while (remaining > 0)
    {
      size_t done;

      SCM_SYSCALL (done = write (fdes, data, remaining));

      if (done == -1)
	SCM_SYSERROR;
      remaining -= done;
      data = ((const char *) data) + done;
    }
}
#undef FUNC_NAME

static void
fport_write (SCM port, const void *data, size_t size)
{
  /* this procedure tries to minimize the number of writes/flushes.  */
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (pt->write_buf == &pt->shortbuf
      || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
    {
      /* "unbuffered" port, or
	 port with empty buffer and data won't fit in buffer. */
      write_all (port, data, size);
      return;
    }

  {
    off_t space = pt->write_end - pt->write_pos;

    if (size <= space)
      {
	/* data fits in buffer.  */
	memcpy (pt->write_pos, data, size);
	pt->write_pos += size;
	if (pt->write_pos == pt->write_end)
	  {
	    fport_flush (port);
	    /* we can skip the line-buffering check if nothing's buffered. */
	    return;
	  }
      }
    else
      {
	memcpy (pt->write_pos, data, space);
	pt->write_pos = pt->write_end;
	fport_flush (port);
	{
	  const void *ptr = ((const char *) data) + space;
	  size_t remaining = size - space;

	  if (size >= pt->write_buf_size)
	    {
	      write_all (port, ptr, remaining);
	      return;
	    }
	  else
	    {
	      memcpy (pt->write_pos, ptr, remaining);
	      pt->write_pos += remaining;
	    }
	}
      }

    /* handle line buffering.  */
    if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
      fport_flush (port);
  }
}

/* becomes 1 when process is exiting: normal exception handling won't
   work by this time.  */
extern int scm_i_terminating;

static void
fport_flush (SCM port)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  scm_t_fport *fp = SCM_FSTREAM (port);
  unsigned char *ptr = pt->write_buf;
  long init_size = pt->write_pos - pt->write_buf;
  long remaining = init_size;

  while (remaining > 0)
    {
      long count;

      SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
      if (count < 0)
	{
	  /* error.  assume nothing was written this call, but
	     fix up the buffer for any previous successful writes.  */
	  long done = init_size - remaining;

	  if (done > 0)
	    {
	      int i;

	      for (i = 0; i < remaining; i++)
		{
		  *(pt->write_buf + i) = *(pt->write_buf + done + i);
		}
	      pt->write_pos = pt->write_buf + remaining;
	    }
	  if (scm_i_terminating)
	    {
	      const char *msg = "Error: could not flush file-descriptor ";
	      char buf[11];
	      size_t written;

	      written = write (2, msg, strlen (msg));
	      sprintf (buf, "%d\n", fp->fdes);
	      written = write (2, buf, strlen (buf));

	      count = remaining;
	    }
	  else if (scm_gc_running_p)
	    {
	      /* silently ignore the error.  scm_error would abort if we
		 called it now.  */
	      count = remaining;
	    }
	  else
	    scm_syserror ("fport_flush");
	}
      ptr += count;
      remaining -= count;
    }
  pt->write_pos = pt->write_buf;
  pt->rw_active = SCM_PORT_NEITHER;
}

/* clear the read buffer and adjust the file position for unread bytes. */
static void
fport_end_input (SCM port, int offset)
{
  scm_t_fport *fp = SCM_FSTREAM (port);
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  offset += pt->read_end - pt->read_pos;

  if (offset > 0)
    {
      pt->read_pos = pt->read_end;
      /* will throw error if unread-char used at beginning of file
	 then attempting to write.  seems correct.  */
      if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
	scm_syserror ("fport_end_input");
    }
  pt->rw_active = SCM_PORT_NEITHER;
}

static int
fport_close (SCM port)
{
  scm_t_fport *fp = SCM_FSTREAM (port);
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  int rv;

  fport_flush (port);
  SCM_SYSCALL (rv = close (fp->fdes));
  if (rv == -1 && errno != EBADF)
    {
      if (scm_gc_running_p)
	/* silently ignore the error.  scm_error would abort if we
	   called it now.  */
	;
      else
	scm_syserror ("fport_close");
    }
  if (pt->read_buf == pt->putback_buf)
    pt->read_buf = pt->saved_read_buf;
  if (pt->read_buf != &pt->shortbuf)
    scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
  if (pt->write_buf != &pt->shortbuf)
    scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
  scm_gc_free (fp, sizeof (*fp), "file port");
  return rv;
}

static size_t
fport_free (SCM port)
{
  fport_close (port);
  return 0;
}

static scm_t_bits
scm_make_fptob ()
{
  scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write);

  scm_set_port_free            (tc, fport_free);
  scm_set_port_print           (tc, fport_print);
  scm_set_port_flush           (tc, fport_flush);
  scm_set_port_end_input       (tc, fport_end_input);
  scm_set_port_close           (tc, fport_close);
  scm_set_port_seek            (tc, fport_seek);
  scm_set_port_truncate        (tc, fport_truncate);
  scm_set_port_input_waiting   (tc, fport_input_waiting);

  return tc;
}

void
scm_init_fports ()
{
  scm_tc16_fport = scm_make_fptob ();

  scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
  scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
  scm_c_define ("_IONBF", scm_from_int (_IONBF));

#include "libguile/fports.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_FPORTS_H
#define SCM_FPORTS_H

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

#include "libguile/ports.h"

/* struct allocated for each buffered FPORT.  */
typedef struct scm_t_fport {
  int fdes;			/* file descriptor.  */
} scm_t_fport;

SCM_API scm_t_bits scm_tc16_fport;

#define SCM_FSTREAM(x) ((scm_t_fport *) SCM_STREAM (x))
#define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes)

#define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_fport))
#define SCM_OPFPORTP(x) (SCM_FPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN))
#define SCM_OPINFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG))
#define SCM_OPOUTFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG))

/* test whether fdes supports random access.  */
#define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1)

SCM_API SCM scm_setbuf0 (SCM port);
SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size);
SCM_API void scm_evict_ports (int fd);
SCM_API SCM scm_open_file (SCM filename, SCM modes);
SCM_API SCM scm_fdes_to_port (int fdes, char *mode, SCM name);
SCM_API SCM scm_file_port_p (SCM obj);
SCM_API void scm_init_fports (void);

/* internal functions */

SCM_API SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name);
SCM_API int scm_i_fport_truncate (SCM, SCM);
SCM_API SCM scm_i_fport_seek (SCM, SCM, int);

#endif  /* SCM_FPORTS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: unknown


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#if 0

/* This whole file is not being compiled.  See futures.h for the
   reason.
*/

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

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/validate.h"
#include "libguile/stime.h"
#include "libguile/threads.h"

#include "libguile/futures.h"

#define LINK(list, obj)				\
do {						\
  SCM_SET_FUTURE_NEXT (obj, list);		\
  list = obj;					\
} while (0)

#define UNLINK(list, obj)			\
do {						\
  obj = list;					\
  list = SCM_FUTURE_NEXT (list);		\
} while (0)

scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

static SCM futures = SCM_EOL;
static SCM young = SCM_EOL;
static SCM old = SCM_EOL;
static SCM undead = SCM_EOL;

static long last_switch;

#ifdef SCM_FUTURES_DEBUG
static int n_dead = 0;

static SCM
count (SCM ls)
{
  int n = 0;
  while (!scm_is_null (ls))
    {
      ++n;
      ls = SCM_FUTURE_NEXT (ls);
    }
  return scm_from_int (n);
}

extern SCM scm_future_cache_status (void);

SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0,
	    (),
	    "Return a list containing number of futures, youngs, olds, undeads and deads.")
#define FUNC_NAME s_scm_future_cache_status
{
  int nd = n_dead;
  n_dead = 0;
  return scm_list_5 (count (futures),
		     count (young),
		     count (old),
		     count (undead),
		     scm_from_int (nd));
}
#undef FUNC_NAME

#endif

SCM *scm_loc_sys_thread_handler;

SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0,
	    (SCM thunk),
	    "Make a future evaluating THUNK.")
#define FUNC_NAME s_scm_make_future
{
  SCM_VALIDATE_THUNK (1, thunk);
  return scm_i_make_future (thunk);
}
#undef FUNC_NAME

static char *s_future = "future";

static void
cleanup (scm_t_future *future)
{
  scm_i_pthread_mutex_destroy (&future->mutex);
  scm_i_pthread_cond_destroy (&future->cond);
  scm_gc_free (future, sizeof (*future), s_future);
#ifdef SCM_FUTURES_DEBUG
  ++n_dead;
#endif
}

static SCM
future_loop (scm_t_future *future)
{
  scm_i_scm_pthread_mutex_lock (&future->mutex);
  do {
    if (future->status == SCM_FUTURE_SIGNAL_ME)
      scm_i_pthread_cond_broadcast (&future->cond);
    future->status = SCM_FUTURE_COMPUTING;
    future->data = (SCM_CLOSUREP (future->data)
		    ? scm_i_call_closure_0 (future->data)
		    : scm_call_0 (future->data));
    scm_i_scm_pthread_cond_wait (&future->cond, &future->mutex);
  } while (!future->die_p);
  future->status = SCM_FUTURE_DEAD;
  scm_i_pthread_mutex_unlock (&future->mutex);
  return SCM_UNSPECIFIED;
}

static SCM
future_handler (scm_t_future *future, SCM key, SCM args)
{
  future->status = SCM_FUTURE_DEAD;
  scm_i_pthread_mutex_unlock (&future->mutex);
  return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
}

static SCM
alloc_future (SCM thunk)
{
  scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future);
  SCM future;
  f->data = SCM_BOOL_F;
  scm_i_pthread_mutex_init (&f->mutex, NULL);
  scm_i_pthread_cond_init (&f->cond, NULL);
  f->die_p = 0;
  f->status = SCM_FUTURE_TASK_ASSIGNED;
  scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
  SCM_NEWSMOB2 (future, scm_tc16_future, futures, f);
  SCM_SET_FUTURE_DATA (future, thunk);
  futures = future;
  scm_i_pthread_mutex_unlock (&future_admin_mutex);
  scm_spawn_thread ((scm_t_catch_body) future_loop,
		    SCM_FUTURE (future),
		    (scm_t_catch_handler) future_handler,
		    SCM_FUTURE (future));
  return future;
}

static void
kill_future (SCM future)
{
  SCM_FUTURE (future)->die_p = 1;
  LINK (undead, future);
}

SCM
scm_i_make_future (SCM thunk)
{
  SCM future;
  scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
  while (1)
    {
      if (!scm_is_null (old))
	UNLINK (old, future);
      else if (!scm_is_null (young))
	UNLINK (young, future);
      else
	{
	  scm_i_pthread_mutex_unlock (&future_admin_mutex);
	  return alloc_future (thunk);
	}
      if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
	kill_future (future);
      else if (!SCM_FUTURE_ALIVE_P (future))
	{
	  scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
	  cleanup (SCM_FUTURE (future));
	}
      else
	break;
    }
  LINK (futures, future);
  scm_i_pthread_mutex_unlock (&future_admin_mutex);
  SCM_SET_FUTURE_DATA (future, thunk);
  SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED);
  scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
  scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
  return future;
}

static SCM
future_mark (SCM ptr) {
  return SCM_FUTURE_DATA (ptr);
}

static int
future_print (SCM exp, SCM port, scm_print_state *pstate)
{
  int writingp = SCM_WRITINGP (pstate);
  scm_puts ("#<future ", port);
  SCM_SET_WRITINGP (pstate, 1);
  scm_iprin1 (SCM_FUTURE_DATA (exp), port, pstate);
  SCM_SET_WRITINGP (pstate, writingp);
  scm_putc ('>', port);
  return !0;
}

SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
	    (SCM future),
	    "If the future @var{x} has not been computed yet, compute and\n"
	    "return @var{x}, otherwise just return the previously computed\n"
	    "value.")
#define FUNC_NAME s_scm_future_ref
{
  SCM res;
  SCM_VALIDATE_FUTURE (1, future);
  scm_i_scm_pthread_mutex_lock (SCM_FUTURE_MUTEX (future));
  if (SCM_FUTURE_STATUS (future) != SCM_FUTURE_COMPUTING)
    {
      SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_SIGNAL_ME);
      scm_i_scm_pthread_cond_wait (SCM_FUTURE_COND (future),
			     SCM_FUTURE_MUTEX (future));
    }
  if (!SCM_FUTURE_ALIVE_P (future))
    {
      scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
      SCM_MISC_ERROR ("requesting result from failed future ~A",
		      scm_list_1 (future));
    }
  res = SCM_FUTURE_DATA (future);
  scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
  return res;
}
#undef FUNC_NAME

static void
kill_futures (SCM victims)
{
  while (!scm_is_null (victims))
    {
      SCM future;
      UNLINK (victims, future);
      kill_future (future);
      scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
    }
}

static void
cleanup_undead ()
{
  SCM next = undead, *nextloc = &undead;
  while (!scm_is_null (next))
    {
      if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next)))
	goto next;
      else if (SCM_FUTURE_ALIVE_P (next))
	{
	  scm_i_pthread_cond_signal (SCM_FUTURE_COND (next));
	  scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
	next:
	  SCM_SET_GC_MARK (next);
	  nextloc = SCM_FUTURE_NEXTLOC (next);
	  next = *nextloc;
	}
      else
	{
	  SCM future;
	  UNLINK (next, future);
	  scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
	  cleanup (SCM_FUTURE (future));
	  *nextloc = next;
	}
    }
}

static void
mark_futures (SCM futures)
{
  while (!scm_is_null (futures))
    {
      SCM_SET_GC_MARK (futures);
      futures = SCM_FUTURE_NEXT (futures);
    }
}

static void *
scan_futures (void *dummy1, void *dummy2, void *dummy3)
{
  SCM next, *nextloc;

  long now = scm_c_get_internal_run_time ();
  if (now - last_switch > SCM_TIME_UNITS_PER_SECOND)
    {
      /* switch out old (> 1 sec), unused futures */
      kill_futures (old);
      old = young;
      young = SCM_EOL;
      last_switch = now;
    }
  else
    mark_futures (young);

  next = futures;
  nextloc = &futures;
  while (!scm_is_null (next))
    {
      if (!SCM_GC_MARK_P (next))
	goto free;
    keep:
      nextloc = SCM_FUTURE_NEXTLOC (next);
      next = *nextloc;
    }
  goto exit;
  while (!scm_is_null (next))
    {
      if (SCM_GC_MARK_P (next))
	{
	  *nextloc = next;
	  goto keep;
	}
    free:
      {
	SCM future;
	UNLINK (next, future);
	SCM_SET_GC_MARK (future);
	LINK (young, future);
      }
    }
  *nextloc = SCM_EOL;
 exit:
  cleanup_undead ();
  mark_futures (old);
  return 0;
}

scm_t_bits scm_tc16_future;

void
scm_init_futures ()
{
  last_switch = scm_c_get_internal_run_time ();

  scm_loc_sys_thread_handler
    = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F));

  scm_tc16_future = scm_make_smob_type ("future", 0);
  scm_set_smob_mark (scm_tc16_future, future_mark);
  scm_set_smob_print (scm_tc16_future, future_print);

  scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0);
#include "libguile/futures.x"
}

#endif

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_FUTURES_H
#define SCM_FUTURES_H

/* Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#if 0

/* Futures have the following known bugs, which should be fixed before
   including them in Guile:

   - The implementation of the thread cache needs to be better so that
     it behaves reasonable under heavy use.

   - The dynamic state of a thread needs to be properly initialized
     when it is retrieved from the cache.
*/

#include "libguile/__scm.h"
#include "libguile/threads.h"

typedef struct scm_t_future {
  SCM data;
  scm_i_pthread_mutex_t mutex;
  scm_i_pthread_cond_t cond;
  int status;
  int die_p;
} scm_t_future;

#define SCM_FUTURE_DEAD 0
#define SCM_FUTURE_SIGNAL_ME -1
#define SCM_FUTURE_COMPUTING 1
#define SCM_FUTURE_TASK_ASSIGNED 2

#define SCM_VALIDATE_FUTURE(pos, obj) \
  SCM_ASSERT_TYPE (SCM_TYP16_PREDICATE (scm_tc16_future, obj), \
		   obj, pos, FUNC_NAME, "future");
#define SCM_FUTURE(future) ((scm_t_future *) SCM_SMOB_DATA_2 (future))
#define SCM_FUTURE_MUTEX(future) (&SCM_FUTURE (future)->mutex)
#define SCM_FUTURE_COND(future) (&SCM_FUTURE (future)->cond)
#define SCM_FUTURE_STATUS(future) (SCM_FUTURE (future)->status)
#define SCM_SET_FUTURE_STATUS(future, x) \
 do { SCM_FUTURE (future)->status = (x); } while (0)
#define SCM_FUTURE_ALIVE_P(future) (SCM_FUTURE_STATUS (future))
#define SCM_FUTURE_DATA(future) (SCM_FUTURE (future)->data)
#define SCM_SET_FUTURE_DATA(future, x) \
 do { SCM_FUTURE (future)->data = (x); } while (0)
#define SCM_FUTURE_NEXT       SCM_SMOB_OBJECT
#define SCM_FUTURE_NEXTLOC    SCM_SMOB_OBJECT_LOC
#define SCM_SET_FUTURE_NEXT   SCM_SET_SMOB_OBJECT

SCM_API scm_t_bits scm_tc16_future;

extern SCM *scm_loc_sys_thread_handler;

SCM_API SCM scm_i_make_future (SCM thunk);
SCM_API SCM scm_make_future (SCM thunk);
SCM_API SCM scm_future_ref (SCM future);

void scm_init_futures (void);

#endif  /* Futures are disabled for now. */

#endif  /* SCM_FUTURES_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <stdio.h>
#include <gmp.h>

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/numbers.h"
#include "libguile/stime.h"
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/tags.h"
#include "libguile/private-gc.h"
#include "libguile/validate.h"
#include "libguile/deprecation.h"
#include "libguile/gc.h"
#include "libguile/srfi-4.h"

#include "libguile/private-gc.h"

long int scm_i_deprecated_memory_return;

/* During collection, this accumulates structures which are to be freed.
 */
SCM scm_i_structs_to_free;

/*
  Init all the free cells in CARD, prepending to *FREE_LIST.

  Return: number of free cells found in this card.

  It would be cleaner to have a separate function sweep_value(), but
  that is too slow (functions with switch statements can't be
  inlined).

  NOTE:

  This function is quite efficient. However, for many types of cells,
  allocation and a de-allocation involves calling malloc() and
  free().

  This is costly for small objects (due to malloc/free overhead.)
  (should measure this).

  It might also be bad for threads: if several threads are allocating
  strings concurrently, then mallocs for both threads may have to
  fiddle with locks.

  It might be interesting to add a separate memory pool for small
  objects to each freelist.

  --hwn.
 */
int
scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
#define FUNC_NAME "sweep_card"
{
  scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
  scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
  int span = seg->span;
  int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
  int free_count  = 0;

  /*
    I tried something fancy with shifting by one bit every word from
    the bitvec in turn, but it wasn't any faster, but quite a bit
    hairier.
   */
  for (p += offset; p < end; p += span, offset += span)
    {
      SCM scmptr = PTR2SCM (p);
      if (SCM_C_BVEC_GET (bitvec, offset))
        continue;

      switch (SCM_TYP7 (scmptr))
	{
	case scm_tcs_struct:
	  /* The card can be swept more than once.  Check that it's
	   * the first time!
	   */
	  if (!SCM_STRUCT_GC_CHAIN (scmptr))
	    {
	      /* Structs need to be freed in a special order.
	       * This is handled by GC C hooks in struct.c.
	       */
	      SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
	      scm_i_structs_to_free = scmptr;
	    }
	  continue;

	case scm_tcs_cons_imcar:
	case scm_tcs_cons_nimcar:
	case scm_tcs_closures:
	case scm_tc7_pws:
	  break;
	case scm_tc7_wvect:
	case scm_tc7_vector:
	  scm_i_vector_free (scmptr);
	  break;

#ifdef CCLO
	case scm_tc7_cclo:
	  scm_gc_free (SCM_CCLO_BASE (scmptr),
		       SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
		       "compiled closure");
	  break;
#endif

	case scm_tc7_number:
	  switch SCM_TYP16 (scmptr)
            {
            case scm_tc16_real:
              break;
            case scm_tc16_big:
              mpz_clear (SCM_I_BIG_MPZ (scmptr));
              /* nothing else to do here since the mpz is in a double cell */
              break;
	    case scm_tc16_complex:
	      scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
			   "complex");
	      break;
	    case scm_tc16_fraction:
	      /* nothing to do here since the num/denum of a fraction
		 are proper SCM objects themselves. */
	      break;
            }
          break;
	case scm_tc7_string:
	  scm_i_string_free (scmptr);
	  break;
	case scm_tc7_stringbuf:
	  scm_i_stringbuf_free (scmptr);
	  break;
	case scm_tc7_symbol:
	  scm_i_symbol_free (scmptr);
	  break;
	case scm_tc7_variable:
	  break;
	case scm_tcs_subrs:
	  /* the various "subrs" (primitives) are never freed */
	  continue;
	case scm_tc7_port:
	  if SCM_OPENP (scmptr)
	    {
	      int k = SCM_PTOBNUM (scmptr);
	      size_t mm;
#if (SCM_DEBUG_CELL_ACCESSES == 1)
	      if (!(k < scm_numptob))
		{
		  fprintf (stderr, "undefined port type");
		  abort();
		}
#endif
	      /* Keep "revealed" ports alive.  */
	      if (scm_revealed_count (scmptr) > 0)
		continue;

	      /* Yes, I really do mean scm_ptobs[k].free */
	      /* rather than ftobs[k].close.  .close */
	      /* is for explicit CLOSE-PORT by user */
	      mm = scm_ptobs[k].free (scmptr);

	      if (mm != 0)
		{
#if SCM_ENABLE_DEPRECATED == 1
		  scm_c_issue_deprecation_warning
		    ("Returning non-0 from a port free function is "
		     "deprecated.  Use scm_gc_free et al instead.");
		  scm_c_issue_deprecation_warning_fmt
		    ("(You just returned non-0 while freeing a %s.)",
		     SCM_PTOBNAME (k));
		  scm_i_deprecated_memory_return += mm;
#else
		  abort ();
#endif
		}

	      SCM_SETSTREAM (scmptr, 0);
	      scm_remove_from_port_table (scmptr);
	      scm_gc_ports_collected++;
	      SCM_CLR_PORT_OPEN_FLAG (scmptr);
	    }
	  break;
	case scm_tc7_smob:
	  switch SCM_TYP16 (scmptr)
	    {
	    case scm_tc_free_cell:
	      free_count --;
	      break;
	    default:
	      {
		int k;
		k = SCM_SMOBNUM (scmptr);
#if (SCM_DEBUG_CELL_ACCESSES == 1)
		if (!(k < scm_numsmob))
		  {
		    fprintf (stderr, "undefined smob type");
		    abort();
		  }
#endif
		if (scm_smobs[k].free)
		  {
		    size_t mm;
		    mm = scm_smobs[k].free (scmptr);
		    if (mm != 0)
		      {
#if SCM_ENABLE_DEPRECATED == 1
			scm_c_issue_deprecation_warning
			  ("Returning non-0 from a smob free function is "
			   "deprecated.  Use scm_gc_free et al instead.");
			scm_c_issue_deprecation_warning_fmt
			  ("(You just returned non-0 while freeing a %s.)",
			   SCM_SMOBNAME (k));
			scm_i_deprecated_memory_return += mm;
#else
			abort();
#endif
		      }
		  }
		break;
	      }
	    }
	  break;
	default:
	  fprintf (stderr, "unknown type");
	  abort();
	}

      SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
      SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
      *free_list = scmptr;
      free_count ++;
    }

  return free_count;
}
#undef FUNC_NAME

/*
  Like sweep, but no complicated logic to do the sweeping.
 */
int
scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
			scm_t_heap_segment*seg)
{
  int span = seg->span;
  scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
  scm_t_cell *p = end - span;

  scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
  int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;

  bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
  SCM_GC_SET_CELL_BVEC (card, bvec_ptr);

  /*
     ASSUMPTION: n_header_cells <= 2.
   */
  for (; p > card;  p -= span)
    {
      const SCM scmptr = PTR2SCM (p);
      SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
      SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
      *free_list = scmptr;
    }

  return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
}

void
scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
{
  scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
  scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
  int span = seg->span;
  int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);

  if (!bitvec)
    /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
    return;

  for (p += offset; p < end; p += span, offset += span)
    {
      scm_t_bits tag = -1;
      SCM scmptr = PTR2SCM (p);

      if (!SCM_C_BVEC_GET (bitvec, offset))
        continue;

      tag = SCM_TYP7 (scmptr);
      if (tag == scm_tc7_smob || tag == scm_tc7_number)
	{
          /* Record smobs and numbers under 16 bits of the tag, so the
             different smob objects are distinguished, and likewise the
             different numbers big, real, complex and fraction. */
	  tag = SCM_TYP16(scmptr);
	}
      else
	switch (tag)
	{
	case scm_tcs_cons_imcar:
	  tag = scm_tc2_int;
	  break;
	case scm_tcs_cons_nimcar:
	  tag = scm_tc3_cons;
	  break;

	case scm_tcs_struct:
	  tag = scm_tc3_struct;
	  break;
	case scm_tcs_closures:
	  tag = scm_tc3_closure;
	  break;
	case scm_tcs_subrs:
	  tag = scm_tc7_asubr;
	  break;
	}

      {
        SCM handle = scm_hashq_create_handle_x (hashtab,
                                                scm_from_int (tag), SCM_INUM0);
        SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
      }
    }
}

/* TAG is the tag word of a cell, return a string which is its name, or NULL
   if unknown.  Currently this is only used by gc-live-object-stats and the
   distinctions between types are oriented towards what that code records
   while scanning what's alive.  */
char const *
scm_i_tag_name (scm_t_bits tag)
{
  switch (tag & 0x7F) /* 7 bits */
    {
    case scm_tcs_struct:
      return "struct";
    case scm_tcs_cons_imcar:
      return "cons (immediate car)";
    case scm_tcs_cons_nimcar:
      return "cons (non-immediate car)";
    case scm_tcs_closures:
      return "closures";
    case scm_tc7_pws:
      return "pws";
    case scm_tc7_wvect:
      return "weak vector";
    case scm_tc7_vector:
      return "vector";
#ifdef CCLO
    case scm_tc7_cclo:
      return "compiled closure";
#endif
    case scm_tc7_number:
      switch (tag)
	{
	case scm_tc16_real:
	  return "real";
	case scm_tc16_big:
	  return "bignum";
	case scm_tc16_complex:
	  return "complex number";
	case scm_tc16_fraction:
	  return "fraction";
	}
      /* shouldn't reach here unless there's a new class of numbers */
      return "number";
    case scm_tc7_string:
      return "string";
    case scm_tc7_stringbuf:
      return "string buffer";
    case scm_tc7_symbol:
      return "symbol";
    case scm_tc7_variable:
      return "variable";
    case scm_tcs_subrs:
      return "subrs";
    case scm_tc7_port:
      return "port";
    case scm_tc7_smob:
      /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
         entry should be ok for our return here */
      return scm_smobs[SCM_TC2SMOBNUM(tag)].name;
    }

  return NULL;
}

#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)

typedef struct scm_dbg_t_list_cell {
  scm_t_bits car;
  struct scm_dbg_t_list_cell * cdr;
} scm_dbg_t_list_cell;

typedef struct scm_dbg_t_double_cell {
  scm_t_bits word_0;
  scm_t_bits word_1;
  scm_t_bits word_2;
  scm_t_bits word_3;
} scm_dbg_t_double_cell;

int scm_dbg_gc_marked_p (SCM obj);
scm_t_cell * scm_dbg_gc_get_card (SCM obj);
scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);

int
scm_dbg_gc_marked_p (SCM obj)
{
  if (!SCM_IMP (obj))
    return SCM_GC_MARK_P(obj);
  else
    return 0;
}

scm_t_cell *
scm_dbg_gc_get_card (SCM obj)
{
  if (!SCM_IMP (obj))
    return SCM_GC_CELL_CARD(obj);
  else
    return NULL;
}

scm_t_c_bvec_long *
scm_dbg_gc_get_bvec (SCM obj)
{
  if (!SCM_IMP (obj))
    return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
  else
    return NULL;
}

#endif


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <assert.h>
#include <stdio.h>

#include "libguile/private-gc.h"
#include "libguile/gc.h"
#include "libguile/deprecation.h"
#include "libguile/private-gc.h"

scm_t_cell_type_statistics scm_i_master_freelist;
scm_t_cell_type_statistics scm_i_master_freelist2;
#ifdef __MINGW32__
scm_t_cell_type_statistics *scm_i_master_freelist_ptr = &scm_i_master_freelist;
scm_t_cell_type_statistics *scm_i_master_freelist2_ptr = &scm_i_master_freelist2;
#endif

/*

In older versions of GUILE GC there was extensive support for
debugging freelists. This was useful, since the freelist was kept
inside the heap, and writing to an object that was GC'd would mangle
the list. Mark bits are now separate, and checking for sane cell
access can be done much more easily by simply checking if the mark bit
is unset before allocation.  --hwn

*/

#if (SCM_ENABLE_DEPRECATED == 1)
#if defined(GUILE_DEBUG_FREELIST)

SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
            (),
	    "DEPRECATED\n")
#define FUNC_NAME "s_scm_map_free_list"
{
  scm_c_issue_deprecation_warning ("map-free-list has been removed from GUILE. Doing nothing\n");
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
            (SCM flag),
	    "DEPRECATED.\n")
#define FUNC_NAME "s_scm_gc_set_debug_check_freelist_x"
{
  scm_c_issue_deprecation_warning ("gc-set-debug-check-freelist! has been removed from GUILE. Doing nothing\n");
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

#endif /* defined (GUILE_DEBUG) */
#endif /* deprecated */

/*
  This adjust FREELIST variables to decide wether or not to allocate
  more heap in the next GC run. It uses scm_gc_cells_collected and scm_gc_cells_collected1
 */

void
scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist)
{
  /* min yield is adjusted upwards so that next predicted total yield
   * (allocated cells actually freed by GC) becomes
   * `min_yield_fraction' of total heap size.  Note, however, that
   * the absolute value of min_yield will correspond to `collected'
   * on one master (the one which currently is triggering GC).
   *
   * The reason why we look at total yield instead of cells collected
   * on one list is that we want to take other freelists into account.
   * On this freelist, we know that (local) yield = collected cells,
   * but that's probably not the case on the other lists.
   *
   * (We might consider computing a better prediction, for example
   *  by computing an average over multiple GC:s.)
   */
  if (freelist->min_yield_fraction)
    {
      /* Pick largest of last two yields. */
      long delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100)
		   - (long) SCM_MAX (scm_gc_cells_collected_1, scm_gc_cells_collected));
#ifdef DEBUGINFO
      fprintf (stderr, " after GC = %lu, delta = %ld\n",
	       (unsigned long) scm_cells_allocated,
	       (long) delta);
#endif
      if (delta > 0)
	freelist->min_yield += delta;
    }
}

static void
scm_init_freelist (scm_t_cell_type_statistics *freelist,
	       int span,
	       int min_yield)
{
  if (min_yield < 1)
    min_yield = 1;
  if (min_yield > 99)
    min_yield = 99;

  freelist->heap_segment_idx = -1;
  freelist->min_yield = 0;
  freelist->min_yield_fraction = min_yield;
  freelist->span = span;
  freelist->collected = 0;
  freelist->collected_1 = 0;
  freelist->heap_size = 0;
}

#if (SCM_ENABLE_DEPRECATED == 1)
 size_t scm_default_init_heap_size_1;
 int scm_default_min_yield_1;
 size_t scm_default_init_heap_size_2;
 int scm_default_min_yield_2;
 size_t scm_default_max_segment_size;
#endif

void
scm_gc_init_freelist (void)
{
  int init_heap_size_1
    = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", SCM_DEFAULT_INIT_HEAP_SIZE_1);
  int init_heap_size_2
    = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2);

  scm_init_freelist (&scm_i_master_freelist2, 2,
		     scm_getenv_int ("GUILE_MIN_YIELD_2", SCM_DEFAULT_MIN_YIELD_2));
  scm_init_freelist (&scm_i_master_freelist, 1,
		     scm_getenv_int ("GUILE_MIN_YIELD_1", SCM_DEFAULT_MIN_YIELD_1));

  scm_max_segment_size = scm_getenv_int ("GUILE_MAX_SEGMENT_SIZE", SCM_DEFAULT_MAX_SEGMENT_SIZE);

  if (scm_max_segment_size <= 0)
    scm_max_segment_size = SCM_DEFAULT_MAX_SEGMENT_SIZE;

  scm_i_make_initial_segment (init_heap_size_1, &scm_i_master_freelist);
  scm_i_make_initial_segment (init_heap_size_2, &scm_i_master_freelist2);

#if (SCM_ENABLE_DEPRECATED == 1)
  if ( scm_default_init_heap_size_1 ||
       scm_default_min_yield_1||
       scm_default_init_heap_size_2||
       scm_default_min_yield_2||
       scm_default_max_segment_size)
    {
      scm_c_issue_deprecation_warning ("Tuning heap parameters with C variables is deprecated. Use environment variables instead.");
    }
#endif
}

void
scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist)
{
  freelist->collected_1 = freelist->collected;
  freelist->collected = 0;

  /*
    at the end we simply start with the lowest segment again.
   */
  freelist->heap_segment_idx = -1;
}

int
scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist)
{
  return SCM_MAX (freelist->collected,freelist->collected_1)  < freelist->min_yield;
}


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <stdio.h>
#include <errno.h>
#include <string.h>

#ifdef __ia64__
#include <ucontext.h>
extern unsigned long * __libc_ia64_register_backing_store_base;
#endif

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/stime.h"
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/tags.h"

#include "libguile/validate.h"
#include "libguile/deprecation.h"
#include "libguile/gc.h"

#include "libguile/private-gc.h"

#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif

#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

/*
  INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
  trigger a GC.

  After startup (at the guile> prompt), we have approximately 100k of
  alloced memory, which won't go away on GC. Let's set the init such
  that we get a nice yield on the next allocation:
*/
#define SCM_DEFAULT_INIT_MALLOC_LIMIT 200*1024
#define SCM_DEFAULT_MALLOC_MINYIELD 40

/* #define DEBUGINFO */

static int scm_i_minyield_malloc;

void
scm_gc_init_malloc (void)
{
  scm_mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
				 SCM_DEFAULT_INIT_MALLOC_LIMIT);
  scm_i_minyield_malloc =  scm_getenv_int ("GUILE_MIN_YIELD_MALLOC",
					   SCM_DEFAULT_MALLOC_MINYIELD);

  if (scm_i_minyield_malloc >= 100)
    scm_i_minyield_malloc = 99;
  if (scm_i_minyield_malloc < 1)
    scm_i_minyield_malloc = 1;

  if (scm_mtrigger < 0)
    scm_mtrigger = SCM_DEFAULT_INIT_MALLOC_LIMIT;
}

/* Function for non-cell memory management.
 */

void *
scm_realloc (void *mem, size_t size)
{
  void *ptr;

  SCM_SYSCALL (ptr = realloc (mem, size));
  if (ptr)
    return ptr;

  scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
  scm_gc_running_p = 1;

  scm_i_sweep_all_segments ("realloc");

  SCM_SYSCALL (ptr = realloc (mem, size));
  if (ptr)
    {
      scm_gc_running_p = 0;
      scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
      return ptr;
    }

  scm_i_gc ("realloc");
  scm_i_sweep_all_segments ("realloc");

  scm_gc_running_p = 0;
  scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);

  SCM_SYSCALL (ptr = realloc (mem, size));
  if (ptr)
    return ptr;

  scm_memory_error ("realloc");
}

void *
scm_malloc (size_t sz)
{
  return scm_realloc (NULL, sz);
}

/*
  Hmm. Should we use the C convention for arguments (i.e. N_ELTS,
  SIZEOF_ELT)? --hwn
 */
void *
scm_calloc (size_t sz)
{
  void * ptr;

  /*
    By default, try to use calloc, as it is likely more efficient than
    calling memset by hand.
   */
  SCM_SYSCALL (ptr = calloc (sz, 1));
  if (ptr)
    return ptr;

  ptr = scm_realloc (NULL, sz);
  memset (ptr, 0x0, sz);
  return ptr;
}

char *
scm_strndup (const char *str, size_t n)
{
  char *dst = scm_malloc (n + 1);
  memcpy (dst, str, n);
  dst[n] = 0;
  return dst;
}

char *
scm_strdup (const char *str)
{
  return scm_strndup (str, strlen (str));
}

static void
decrease_mtrigger (size_t size, const char * what)
{
  scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);

  if (size > scm_mallocated)
    {
      fprintf (stderr, "`scm_mallocated' underflow.  This means that more "
	       "memory was unregistered\n"
	       "via `scm_gc_unregister_collectable_memory ()' than "
	       "registered.\n");
      abort ();
    }

  scm_mallocated -= size;
  scm_gc_malloc_collected += size;
  scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
}

static void
increase_mtrigger (size_t size, const char *what)
{
  size_t mallocated = 0;
  int overflow = 0, triggered = 0;

  scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
  if (ULONG_MAX - size < scm_mallocated)
    overflow = 1;
  else
    {
      scm_mallocated += size;
      mallocated = scm_mallocated;
      if (scm_mallocated > scm_mtrigger)
	triggered = 1;
    }
  scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);

  if (overflow)
    scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");

  /*
    A program that uses a lot of malloced collectable memory (vectors,
    strings), will use a lot of memory off the cell-heap; it needs to
    do GC more often (before cells are exhausted), otherwise swapping
    and malloc management will tie it down.
   */
  if (triggered)
    {
      unsigned long prev_alloced;
      float yield;

      scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
      scm_gc_running_p = 1;

      prev_alloced  = mallocated;
      scm_i_gc (what);
      scm_i_sweep_all_segments ("mtrigger");

      yield = (((float) prev_alloced - (float) scm_mallocated)
	       / (float) prev_alloced);

      scm_gc_malloc_yield_percentage = (int) (100  * yield);

#ifdef DEBUGINFO
      fprintf (stderr,  "prev %lud , now %lud, yield %4.2lf, want %d",
	       prev_alloced,
	       scm_mallocated,
	       100.0 * yield,
	       scm_i_minyield_malloc);
#endif

      if (yield < scm_i_minyield_malloc /  100.0)
	{
	  /*
	    We make the trigger a little larger, even; If you have a
	    program that builds up a lot of data in strings, then the
	    desired yield will never be satisfied.

	    Instead of getting bogged down, we let the mtrigger grow
	    strongly with it.
	   */
	  float no_overflow_trigger = scm_mallocated * 110.0;

	  no_overflow_trigger /= (float)  (100.0 - scm_i_minyield_malloc);

	  if (no_overflow_trigger >= (float) ULONG_MAX)
	    scm_mtrigger = ULONG_MAX;
	  else
	    scm_mtrigger =  (unsigned long) no_overflow_trigger;

#ifdef DEBUGINFO
	  fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n",
		   scm_mtrigger);
#endif
	}

      scm_gc_running_p = 0;
      scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
    }
}

void
scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
{
  increase_mtrigger (size, what);
#ifdef GUILE_DEBUG_MALLOC
  if (mem)
    scm_malloc_register (mem, what);
#endif
}

void
scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
{
  decrease_mtrigger (size, what);
#ifdef GUILE_DEBUG_MALLOC
  if (mem)
    scm_malloc_unregister (mem);
#endif
}

void *
scm_gc_malloc (size_t size, const char *what)
{
  /*
    The straightforward implementation below has the problem
     that it might call the GC twice, once in scm_malloc and then
     again in scm_gc_register_collectable_memory.  We don't really
     want the second GC since it will not find new garbage.

     Note: this is a theoretical peeve. In reality, malloc() never
     returns NULL. Usually, memory is overcommitted, and when you try
     to write it the program is killed with signal 11. --hwn
  */

  void *ptr = size ? scm_malloc (size) : NULL;
  scm_gc_register_collectable_memory (ptr, size, what);
  return ptr;
}

void *
scm_gc_calloc (size_t size, const char *what)
{
  void *ptr = scm_gc_malloc (size, what);
  memset (ptr, 0x0, size);
  return ptr;
}

void *
scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what)
{
  void *ptr;

  /* XXX - see scm_gc_malloc. */

  /*
  scm_realloc() may invalidate the block pointed to by WHERE, eg. by
  unmapping it from memory or altering the contents.  Since
  increase_mtrigger() might trigger a GC that would scan
  MEM, it is crucial that this call precedes realloc().
  */

  decrease_mtrigger (old_size, what);
  increase_mtrigger (new_size, what);

  ptr = scm_realloc (mem, new_size);

#ifdef GUILE_DEBUG_MALLOC
  if (mem)
    scm_malloc_reregister (mem, ptr, what);
#endif

  return ptr;
}

void
scm_gc_free (void *mem, size_t size, const char *what)
{
  scm_gc_unregister_collectable_memory (mem, size, what);
  if (mem)
    free (mem);
}

char *
scm_gc_strndup (const char *str, size_t n, const char *what)
{
  char *dst = scm_gc_malloc (n+1, what);
  memcpy (dst, str, n);
  dst[n] = 0;
  return dst;
}

char *
scm_gc_strdup (const char *str, const char *what)
{
  return scm_gc_strndup (str, strlen (str), what);
}

#if SCM_ENABLE_DEPRECATED == 1

/* {Deprecated front end to malloc}
 *
 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
 * scm_done_free
 *
 * These functions provide services comparable to malloc, realloc, and
 * free.  They should be used when allocating memory that will be under
 * control of the garbage collector, i.e., if the memory may be freed
 * during garbage collection.
 *
 * They are deprecated because they weren't really used the way
 * outlined above, and making sure to return the right amount from
 * smob free routines was sometimes difficult when dealing with nested
 * data structures.  We basically want everybody to review their code
 * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
 * instead.  In some cases, where scm_must_malloc has been used
 * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
 */

void *
scm_must_malloc (size_t size, const char *what)
{
  scm_c_issue_deprecation_warning
    ("scm_must_malloc is deprecated.  "
     "Use scm_gc_malloc and scm_gc_free instead.");

  return scm_gc_malloc (size, what);
}

void *
scm_must_realloc (void *where,
		  size_t old_size,
		  size_t size,
		  const char *what)
{
  scm_c_issue_deprecation_warning
    ("scm_must_realloc is deprecated.  "
     "Use scm_gc_realloc and scm_gc_free instead.");

  return scm_gc_realloc (where, old_size, size, what);
}

char *
scm_must_strndup (const char *str, size_t length)
{
  scm_c_issue_deprecation_warning
    ("scm_must_strndup is deprecated.  "
     "Use scm_gc_strndup and scm_gc_free instead.");

  return scm_gc_strndup (str, length, "string");
}

char *
scm_must_strdup (const char *str)
{
  scm_c_issue_deprecation_warning
    ("scm_must_strdup is deprecated.  "
     "Use scm_gc_strdup and scm_gc_free instead.");

  return scm_gc_strdup (str, "string");
}

void
scm_must_free (void *obj)
#define FUNC_NAME "scm_must_free"
{
  scm_c_issue_deprecation_warning
    ("scm_must_free is deprecated.  "
     "Use scm_gc_malloc and scm_gc_free instead.");

#ifdef GUILE_DEBUG_MALLOC
  scm_malloc_unregister (obj);
#endif
  if (obj)
    free (obj);
  else
    {
      fprintf (stderr,"freeing NULL pointer");
      abort ();
    }
}
#undef FUNC_NAME

void
scm_done_malloc (long size)
{
  scm_c_issue_deprecation_warning
    ("scm_done_malloc is deprecated.  "
     "Use scm_gc_register_collectable_memory instead.");

  if (size >= 0)
    scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
  else
    scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
}

void
scm_done_free (long size)
{
  scm_c_issue_deprecation_warning
    ("scm_done_free is deprecated.  "
     "Use scm_gc_unregister_collectable_memory instead.");

  if (size >= 0)
    scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
  else
    scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
}

#endif /* SCM_ENABLE_DEPRECATED == 1 */


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <assert.h>

#ifdef __ia64__
#include <ucontext.h>
extern unsigned long * __libc_ia64_register_backing_store_base;
#endif

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/stime.h"
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/tags.h"
#include "libguile/private-gc.h"
#include "libguile/validate.h"
#include "libguile/deprecation.h"
#include "libguile/gc.h"
#include "libguile/guardians.h"

#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif

#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

/*
  Entry point for this file.
 */
void
scm_mark_all (void)
{
  long j;
  int loops;

  scm_i_init_weak_vectors_for_gc ();
  scm_i_init_guardians_for_gc ();

  scm_i_clear_mark_space ();

  /* Mark every thread's stack and registers */
  scm_threads_mark_stacks ();

  j = SCM_NUM_PROTECTS;
  while (j--)
    scm_gc_mark (scm_sys_protects[j]);

  /* mark the registered roots */
  {
    size_t i;
    for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots); ++i)
      {
	SCM l = SCM_HASHTABLE_BUCKET (scm_gc_registered_roots, i);
	for (; !scm_is_null (l); l = SCM_CDR (l))
	  {
	    SCM *p = (SCM *) (scm_to_ulong (SCM_CAAR (l)));
	    scm_gc_mark (*p);
	  }
      }
  }

  scm_mark_subr_table ();

  loops = 0;
  while (1)
    {
      int again;
      loops++;

      /* Mark the non-weak references of weak vectors.  For a weak key
	 alist vector, this would mark the values for keys that are
	 marked.  We need to do this in a loop until everything
	 settles down since the newly marked values might be keys in
	 other weak key alist vectors, for example.
      */
      again = scm_i_mark_weak_vectors_non_weaks ();
      if (again)
	continue;

      /* Now we scan all marked guardians and move all unmarked objects
	 from the accessible to the inaccessible list.
      */
      scm_i_identify_inaccessible_guardeds ();

      /* When we have identified all inaccessible objects, we can mark
	 them.
      */
      again = scm_i_mark_inaccessible_guardeds ();

      /* This marking might have changed the situation for weak vectors
	 and might have turned up new guardians that need to be processed,
	 so we do it all over again.
      */
      if (again)
	continue;

      /* Nothing new marked in this round, we are done.
       */
      break;
    }

  /* fprintf (stderr, "%d loops\n", loops); */

  /* Remove all unmarked entries from the weak vectors.
   */
  scm_i_remove_weaks_from_weak_vectors ();

  /* Bring hashtables upto date.
   */
  scm_i_scan_weak_hashtables ();
}

/* {Mark/Sweep}
 */

/*
  Mark an object precisely, then recurse.
 */
void
scm_gc_mark (SCM ptr)
{
  if (SCM_IMP (ptr))
    return;

  if (SCM_GC_MARK_P (ptr))
    return;

  SCM_SET_GC_MARK (ptr);
  scm_gc_mark_dependencies (ptr);
}

/*

Mark the dependencies of an object.

Prefetching:

Should prefetch objects before marking, i.e. if marking a cell, we
should prefetch the car, and then mark the cdr. This will improve CPU
cache misses, because the car is more likely to be in core when we
finish the cdr.

See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
garbage collector cache misses.

Prefetch is supported on GCC >= 3.1

(Some time later.)

Tried this with GCC 3.1.1 -- the time differences are barely measurable.
Perhaps this would work better with an explicit markstack?

*/

void
scm_gc_mark_dependencies (SCM p)
#define FUNC_NAME "scm_gc_mark_dependencies"
{
  register long i;
  register SCM ptr;
  SCM cell_type;

  ptr = p;
 scm_mark_dependencies_again:

  cell_type = SCM_GC_CELL_TYPE (ptr);
  switch (SCM_ITAG7 (cell_type))
    {
    case scm_tcs_cons_nimcar:
      if (SCM_IMP (SCM_CDR (ptr)))
	{
	  ptr = SCM_CAR (ptr);
	  goto gc_mark_nimp;
	}

      scm_gc_mark (SCM_CAR (ptr));
      ptr = SCM_CDR (ptr);
      goto gc_mark_nimp;
    case scm_tcs_cons_imcar:
      ptr = SCM_CDR (ptr);
      goto gc_mark_loop;
    case scm_tc7_pws:

      scm_gc_mark (SCM_SETTER (ptr));
      ptr = SCM_PROCEDURE (ptr);
      goto gc_mark_loop;
    case scm_tcs_struct:
      {
	/* XXX - use less explicit code. */
	scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
	scm_t_bits * vtable_data = (scm_t_bits *) word0;
	SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
	long len = scm_i_symbol_length (layout);
	const char *fields_desc = scm_i_symbol_chars (layout);
	scm_t_bits *struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);

	if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
	  {
	    scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
	    scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
	  }
	if (len)
	  {
	    long x;

	    for (x = 0; x < len - 2; x += 2, ++struct_data)
	      if (fields_desc[x] == 'p')
		scm_gc_mark (SCM_PACK (*struct_data));
	    if (fields_desc[x] == 'p')
	      {
		if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
		  for (x = *struct_data++; x; --x, ++struct_data)
		    scm_gc_mark (SCM_PACK (*struct_data));
		else
		  scm_gc_mark (SCM_PACK (*struct_data));
	      }
	  }
	/* mark vtable */
	ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
	goto gc_mark_loop;
      }
      break;
    case scm_tcs_closures:
      if (SCM_IMP (SCM_ENV (ptr)))
	{
	  ptr = SCM_CLOSCAR (ptr);
	  goto gc_mark_nimp;
	}
      scm_gc_mark (SCM_CLOSCAR (ptr));
      ptr = SCM_ENV (ptr);
      goto gc_mark_nimp;
    case scm_tc7_vector:
      i = SCM_SIMPLE_VECTOR_LENGTH (ptr);
      if (i == 0)
	break;
      while (--i > 0)
	{
	  SCM elt = SCM_SIMPLE_VECTOR_REF (ptr, i);
	  if (SCM_NIMP (elt))
	    scm_gc_mark (elt);
	}
      ptr = SCM_SIMPLE_VECTOR_REF (ptr, 0);
      goto gc_mark_loop;
#ifdef CCLO
    case scm_tc7_cclo:
      {
	size_t i = SCM_CCLO_LENGTH (ptr);
	size_t j;
	for (j = 1; j != i; ++j)
	  {
	    SCM obj = SCM_CCLO_REF (ptr, j);
	    if (!SCM_IMP (obj))
	      scm_gc_mark (obj);
	  }
	ptr = SCM_CCLO_REF (ptr, 0);
	goto gc_mark_loop;
      }
#endif

    case scm_tc7_string:
      ptr = scm_i_string_mark (ptr);
      goto gc_mark_loop;
    case scm_tc7_stringbuf:
      ptr = scm_i_stringbuf_mark (ptr);
      goto gc_mark_loop;

    case scm_tc7_number:
      if (SCM_TYP16 (ptr) == scm_tc16_fraction)
	{
	  scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
	  ptr = SCM_CELL_OBJECT_2 (ptr);
	  goto gc_mark_loop;
	}
      break;

    case scm_tc7_wvect:
      scm_i_mark_weak_vector (ptr);
      break;

    case scm_tc7_symbol:
      ptr = scm_i_symbol_mark (ptr);
      goto gc_mark_loop;
    case scm_tc7_variable:
      ptr = SCM_CELL_OBJECT_1 (ptr);
      goto gc_mark_loop;
    case scm_tcs_subrs:
      break;
    case scm_tc7_port:
      i = SCM_PTOBNUM (ptr);
#if (SCM_DEBUG_CELL_ACCESSES == 1)
      if (!(i < scm_numptob))
	{
	  fprintf (stderr, "undefined port type");
	  abort();
	}
#endif
      if (SCM_PTAB_ENTRY(ptr))
	scm_gc_mark (SCM_FILENAME (ptr));
      if (scm_ptobs[i].mark)
	{
	  ptr = (scm_ptobs[i].mark) (ptr);
	  goto gc_mark_loop;
	}
      else
	return;
      break;
    case scm_tc7_smob:
      switch (SCM_TYP16 (ptr))
	{ /* should be faster than going through scm_smobs */
	case scm_tc_free_cell:
	  /* We have detected a free cell.  This can happen if non-object data
	   * on the C stack points into guile's heap and is scanned during
	   * conservative marking.  */
	  break;
	default:
	  i = SCM_SMOBNUM (ptr);
#if (SCM_DEBUG_CELL_ACCESSES == 1)
	  if (!(i < scm_numsmob))
	    {
	      fprintf (stderr, "undefined smob type");
	      abort();
	    }
#endif
	  if (scm_smobs[i].mark)
	    {
	      ptr = (scm_smobs[i].mark) (ptr);
	      goto gc_mark_loop;
	    }
	  else
	    return;
	}
      break;
    default:
      fprintf (stderr, "unknown type");
      abort();
    }

  /*
    If we got here, then exhausted recursion options for PTR.  we
    return (careful not to mark PTR, it might be the argument that we
    were called with.)
   */
  return ;

 gc_mark_loop:
  if (SCM_IMP (ptr))
    return;

 gc_mark_nimp:
  {
    int valid_cell = CELL_P (ptr);

#if (SCM_DEBUG_CELL_ACCESSES == 1)
    if (scm_debug_cell_accesses_p)
      {
    /* We are in debug mode.  Check the ptr exhaustively. */

	valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0);
      }

#endif
    if (!valid_cell)
      {
	fprintf (stderr, "rogue pointer in heap");
	abort();
      }
  }

 if (SCM_GC_MARK_P (ptr))
  {
    return;
  }

  SCM_SET_GC_MARK (ptr);

  goto   scm_mark_dependencies_again;

}
#undef FUNC_NAME

/* Mark a region conservatively */
void
scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
{
  unsigned long m;

  for (m = 0; m < n; ++m)
    {
      SCM obj = * (SCM *) &x[m];
      long int segment = scm_i_find_heap_segment_containing_object (obj);
      if (segment >= 0)
	scm_gc_mark (obj);
    }
}

/* The function scm_in_heap_p determines whether an SCM value can be regarded as a
 * pointer to a cell on the heap.
 */
int
scm_in_heap_p (SCM value)
{
  long int segment = scm_i_find_heap_segment_containing_object (value);
  return (segment >= 0);
}

#if SCM_ENABLE_DEPRECATED == 1

/* If an allocated cell is detected during garbage collection, this
 * means that some code has just obtained the object but was preempted
 * before the initialization of the object was completed.  This meanst
 * that some entries of the allocated cell may already contain SCM
 * objects.  Therefore, allocated cells are scanned conservatively.
 */

scm_t_bits scm_tc16_allocated;

static SCM
allocated_mark (SCM cell)
{
  unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
  unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
  unsigned int i;

  for (i = 1; i != span * 2; ++i)
    {
      SCM obj = SCM_CELL_OBJECT (cell, i);
      long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
      if (obj_segment >= 0)
	scm_gc_mark (obj);
    }
  return SCM_BOOL_F;
}

SCM
scm_deprecated_newcell (void)
{
  scm_c_issue_deprecation_warning
    ("SCM_NEWCELL is deprecated.  Use `scm_cell' instead.\n");

  return scm_cell (scm_tc16_allocated, 0);
}

SCM
scm_deprecated_newcell2 (void)
{
  scm_c_issue_deprecation_warning
    ("SCM_NEWCELL2 is deprecated.  Use `scm_double_cell' instead.\n");

  return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
}

#endif /* SCM_ENABLE_DEPRECATED == 1 */

void
scm_gc_init_mark(void)
{
#if SCM_ENABLE_DEPRECATED == 1
  scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
  scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
#endif
}


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <assert.h>
#include <stdio.h>
#include <string.h>

#include "libguile/_scm.h"
#include "libguile/pairs.h"
#include "libguile/gc.h"
#include "libguile/private-gc.h"

size_t scm_max_segment_size;

scm_t_heap_segment *
scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl)
{
  scm_t_heap_segment * shs = malloc (sizeof (scm_t_heap_segment));

  if (!shs)
    {
      fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n");
      abort ();
    }

  shs->bounds[0] = NULL;
  shs->bounds[1] = NULL;
  shs->malloced = NULL;
  shs->span = fl->span;
  shs->freelist  = fl;
  shs->next_free_card = NULL;

  return shs;
}

void
scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab)
{
  scm_t_cell *p = seg->bounds[0];
  while (p <  seg->bounds[1])
    {
      scm_i_card_statistics (p, tab, seg);
      p += SCM_GC_CARD_N_CELLS;
    }
}

/*
  Fill SEGMENT with memory both for data and mark bits.

  RETURN:  1 on success, 0 failure
 */
int
scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested)
{
  /*
    round upwards
   */
  int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
  int card_count =1 + (requested / sizeof (scm_t_cell)) /  card_data_cell_count;

  /*
    one card extra due to alignment
  */
  size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD
    + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG
    ;
  scm_t_c_bvec_long * bvec_ptr = 0;
  scm_t_cell *  memory = 0;

  /*
    We use calloc to alloc the heap. On GNU libc this is
    equivalent to mmapping /dev/zero
   */
  SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed));

  if (memory == NULL)
    return 0;

  segment->malloced = memory;
  segment->bounds[0] = SCM_GC_CARD_UP (memory);
  segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS;

  segment->freelist->heap_size += scm_i_segment_cell_count (segment);

  bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1];

  /*
    Don't init the mem or the bitvector. This is handled by lazy
    sweeping.
  */

  segment->next_free_card = segment->bounds[0];
  segment->first_time = 1;
  return 1;
}

int
scm_i_segment_card_count (scm_t_heap_segment * seg)
{
  return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
}

/*
  Return the number of available single-cell data cells.
 */
int
scm_i_segment_cell_count (scm_t_heap_segment * seg)
{
  return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
    + ((seg->span == 2) ? -1 : 0);
}

void
scm_i_clear_segment_mark_space (scm_t_heap_segment *seg)
{
  scm_t_cell *  markspace = seg->bounds[1];

  memset (markspace, 0x00,
	  scm_i_segment_card_count (seg) *  SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG);
}

/*
  Sweep cards from SEG until we've gathered THRESHOLD cells

  RETURN:

  Freelist.
*/
SCM
scm_i_sweep_some_cards (scm_t_heap_segment *seg)
{
  SCM cells = SCM_EOL;
  int threshold = 512;
  int collected = 0;
  int (*sweeper) (scm_t_cell *, SCM *, scm_t_heap_segment* )
    = (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card;

  scm_t_cell * next_free = seg->next_free_card;
  int cards_swept = 0;

  while (collected < threshold && next_free < seg->bounds[1])
    {
      collected += (*sweeper) (next_free, &cells, seg);
      next_free += SCM_GC_CARD_N_CELLS;
      cards_swept ++;
    }

  scm_gc_cells_swept +=  cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
  scm_gc_cells_collected += collected * seg->span;

  if (!seg->first_time)
    {
      scm_gc_cells_allocated_acc +=
	(scm_cells_allocated - scm_last_cells_allocated);

      scm_cells_allocated -= collected * seg->span;
      scm_last_cells_allocated = scm_cells_allocated;
    }
  seg->freelist->collected += collected  * seg->span;

  if(next_free == seg->bounds[1])
    {
      seg->first_time = 0;
    }

  seg->next_free_card = next_free;
  return cells;
}

/*
  Force a sweep of this entire segment. This doesn't modify sweep
  statistics, it just frees the memory pointed to by to-be-swept
  cells.

  Implementation is slightly ugh.

  FIXME: if you do scm_i_sweep_segment(), and then allocate from this
  segment again, the statistics are off.
 */
void
scm_i_sweep_segment (scm_t_heap_segment * seg)
{
  scm_t_cell * p = seg->next_free_card;
  int yield = scm_gc_cells_collected;
  int coll = seg->freelist->collected;
  unsigned long alloc = scm_cells_allocated ;
  unsigned long last_alloc = scm_last_cells_allocated;
  double last_total
    = scm_gc_cells_allocated_acc
    + (alloc - last_alloc);

  while (scm_i_sweep_some_cards (seg) != SCM_EOL)
    ;

  scm_gc_cells_collected = yield;

  /*
   * restore old stats.
   */
  scm_gc_cells_allocated_acc = last_total;
  scm_cells_allocated = alloc;
  scm_last_cells_allocated = alloc;

  seg->freelist->collected = coll;
  seg->next_free_card =p;
}

void
scm_i_sweep_all_segments (char const  *reason)
{
  int i= 0;

  for (i = 0; i < scm_i_heap_segment_table_size; i++)
    {
      scm_i_sweep_segment (scm_i_heap_segment_table[i]);
    }
}

/*
  Heap segment table.

  The table is sorted by the address of the data itself. This makes
  for easy lookups. This is not portable: according to ANSI C,
  pointers can only be compared within the same object (i.e. the same
  block of malloced memory.). For machines with weird architectures,
  this should be revised.

  (Apparently, for this reason 1.6 and earlier had macros for pointer
  comparison. )

  perhaps it is worthwhile to remove the 2nd level of indirection in
  the table, but this certainly makes for cleaner code.
*/
scm_t_heap_segment ** scm_i_heap_segment_table;
size_t scm_i_heap_segment_table_size;
scm_t_cell *lowest_cell;
scm_t_cell *highest_cell;

void
scm_i_clear_mark_space (void)
{
  int i = 0;
  for (; i < scm_i_heap_segment_table_size; i++)
    {
      scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
    }
}

/*
  RETURN: index of inserted segment.
 */
int
scm_i_insert_segment (scm_t_heap_segment * seg)
{
  size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
  SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **)
			       realloc ((char *)scm_i_heap_segment_table, size)));

  /*
    We can't alloc 4 more bytes. This is hopeless.
   */
  if (!scm_i_heap_segment_table)
    {
      fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
      abort ();
    }

  if (!lowest_cell)
    {
      lowest_cell = seg->bounds[0];
      highest_cell = seg->bounds[1];
    }
  else
    {
      lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
      highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
    }

  {
    int i = 0;
    int j = 0;

    while (i < scm_i_heap_segment_table_size
	   && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
      i++;

    /*
      We insert a new entry; if that happens to be before the
      "current" segment of a freelist, we must move the freelist index
      as well.
    */
    if (scm_i_master_freelist.heap_segment_idx >= i)
      scm_i_master_freelist.heap_segment_idx ++;
    if (scm_i_master_freelist2.heap_segment_idx >= i)
      scm_i_master_freelist2.heap_segment_idx ++;

    for (j = scm_i_heap_segment_table_size; j > i; --j)
      scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];

    scm_i_heap_segment_table [i] = seg;
    scm_i_heap_segment_table_size ++;

    return i;
  }
}

SCM
scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl)
{
  int i = fl->heap_segment_idx;
  SCM collected = SCM_EOL;

  if (i == -1)
    i++;

  for (;
       i < scm_i_heap_segment_table_size; i++)
    {
      if (scm_i_heap_segment_table[i]->freelist != fl)
	continue;

      collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]);

      if (collected != SCM_EOL)       /* Don't increment i */
	break;
    }

  fl->heap_segment_idx = i;

  return collected;
}

void
scm_i_reset_segments (void)
{
  int i = 0;
  for (; i < scm_i_heap_segment_table_size; i++)
    {
      scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
      seg->next_free_card = seg->bounds[0];
    }
}

/*
  Return a hashtab with counts of live objects, with tags as keys.
 */

SCM
scm_i_all_segments_statistics (SCM tab)
{
  int i = 0;
  for (; i < scm_i_heap_segment_table_size; i++)
    {
      scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
      scm_i_heap_segment_statistics (seg, tab);
    }

  return tab;
}

/*
  Determine whether the given value does actually represent a cell in
  some heap segment.  If this is the case, the number of the heap
  segment is returned.  Otherwise, -1 is returned.  Binary search is
  used to determine the heap segment that contains the cell.

  I think this function is too long to be inlined. --hwn
*/
long int
scm_i_find_heap_segment_containing_object (SCM obj)
{
  if (!CELL_P (obj))
    return -1;

  if ((scm_t_cell* ) obj < lowest_cell || (scm_t_cell*) obj >= highest_cell)
    return -1;

    {
      scm_t_cell *  ptr = SCM2PTR (obj);
      unsigned long int i = 0;
      unsigned long int j = scm_i_heap_segment_table_size - 1;

      if (ptr < scm_i_heap_segment_table[i]->bounds[0])
	return -1;
      else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
	return -1;
      else
	{
	  while (i < j)
	    {
	      if (ptr < scm_i_heap_segment_table[i]->bounds[1])
		{
		  break;
		}
	      else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
		{
		  i = j;
		  break;
		}
	      else
		{
		  unsigned long int k = (i + j) / 2;

		  if (k == i)
		    return -1;
		  else if (ptr <  scm_i_heap_segment_table[k]->bounds[1])
		    {
		      j = k;
		      ++i;
		      if (ptr <  scm_i_heap_segment_table[i]->bounds[0])
			return -1;
		    }
		  else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
		    {
		      i = k;
		      --j;
		      if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
			return -1;
		    }
		}
	    }

	  if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
	    return -1;
	  else if (SCM_GC_IN_CARD_HEADERP (ptr))
	    return -1;
	  else
	    return i;
	}
    }
}

/*
  Important entry point: try to grab some memory, and make it into a
  segment.

  RETURN: the index of the segment.
 */
int
scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
			    policy_on_error error_policy)
{
  size_t len;

  {
    /* Assure that the new segment is predicted to be large enough.
     *
     * New yield should at least equal GC fraction of new heap size, i.e.
     *
     *   y + dh > f * (h + dh)
     *
     *    y : yield
     *    f : min yield fraction
     *    h : heap size
     *   dh : size of new heap segment
     *
     * This gives dh > (f * h - y) / (1 - f)
     */
    float f = freelist->min_yield_fraction / 100.0;
    float h = SCM_HEAP_SIZE;
    float min_cells
      = (f * h - scm_gc_cells_collected) / (1.0 - f);

    /* Make heap grow with factor 1.5 */
    len =  freelist->heap_size / 2;
#ifdef DEBUGINFO
    fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
#endif

    if (len < min_cells)
      len = (unsigned long) min_cells;
    len *= sizeof (scm_t_cell);
    /* force new sampling */
    freelist->collected = LONG_MAX;
  }

  if (len > scm_max_segment_size)
    len = scm_max_segment_size;
  if (len < SCM_MIN_HEAP_SEG_SIZE)
    len = SCM_MIN_HEAP_SEG_SIZE;

  {
    scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);

    /* Allocate with decaying ambition. */
    while (len >= SCM_MIN_HEAP_SEG_SIZE)
      {
	if (scm_i_initialize_heap_segment_data (seg, len))
	  {
	    return scm_i_insert_segment (seg);
	  }

	len /= 2;
      }
  }

  if (error_policy == abort_on_error)
    {
      fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
      abort ();
    }
  return -1;
}

void
scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist)
{
  scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);

  if (init_heap_size < 1)
    {
      init_heap_size =  SCM_DEFAULT_INIT_HEAP_SIZE_1;
    }

  if (scm_i_initialize_heap_segment_data (seg, init_heap_size))
    {
      freelist->heap_segment_idx = scm_i_insert_segment (seg);
    }

  /*
    Why the fuck  try twice? --hwn
   */
  if (!seg->malloced)
    {
      scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE);
    }

  if (freelist->min_yield_fraction)
    freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
			    / 100);
}