guile/libguile/gsubr.c

/* Copyright 1995-2001,2006,2008-2011,2013,2015,2018
     Free Software Foundation, Inc.

   This file is part of Guile.

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

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

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



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

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

#include "foreign.h"
#include "frames.h"
#include "instructions.h"
#include "jit.h"
#include "modules.h"
#include "numbers.h"
#include "private-options.h"
#include "programs.h"
#include "srfi-4.h"
#include "symbols.h"
#include "threads.h"

#include "gsubr.h"



/*
 * gsubr.c
 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
 * and rest arguments.
 */

static scm_i_pthread_mutex_t admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

static void **subrs = NULL;
static uint32_t next_subr_idx = 0;
static uint32_t subrs_array_size = 0;

static uint32_t
alloc_subr_idx (void *subr)
{
  uint32_t idx;

  scm_i_pthread_mutex_lock (&admin_mutex);

  idx = next_subr_idx++;

  if (idx > 0xffffff) abort ();

  if (idx >= subrs_array_size)
    {
      void **new_subrs;

      if (subrs_array_size)
        subrs_array_size *= 2;
      else
        /* In July 2018 there were 1140 subrs defined in stock Guile.  */
        subrs_array_size = 1500;

      /* Leak this allocation, as code lives as long as the program
         does.  In the likely case, we only make one malloc for the
         program; in the general case it's still O(n) in number of subrs
         because of the geometric factor.  Use malloc instead of GC
         allocations because it's not traceable and not collectable.  */
      new_subrs = malloc (subrs_array_size * sizeof (void*));
      memcpy (new_subrs, subrs, idx * sizeof (void*));
      subrs = new_subrs;
    }

  subrs[idx] = subr;

  scm_i_pthread_mutex_unlock (&admin_mutex);

  return idx;
}



static SCM *names = NULL;
static uint32_t names_array_size = 0;

static void
record_subr_name (uint32_t idx, SCM name)
{
  scm_i_pthread_mutex_lock (&admin_mutex);

  if (idx >= names_array_size)
    {
      SCM *new_names;
      uint32_t new_size;

      /* See comments in alloc_subr_idx about how we choose 1500 as
         initial size.  It's a GC-managed allocation though.  */

      if (names_array_size)
        new_size = names_array_size * 2;
      else
        new_size = 1500;

      new_names = SCM_GC_MALLOC (new_size * sizeof (SCM));
      memcpy (new_names, names, names_array_size * sizeof (SCM));
      while (names_array_size < new_size)
        new_names[names_array_size++] = SCM_BOOL_F;
      names = new_names;
      names_array_size = new_size;
    }

  names[idx] = name;

  scm_i_pthread_mutex_unlock (&admin_mutex);
}



static char *arena = NULL;
static size_t arena_used = 0;
static size_t arena_size = 0;

static size_t
round_up_power_of_two (size_t n, size_t m)
{
  return (n + (m-1)) & ~(m-1);
}

static char *
alloc (size_t byte_size)
{
  char *ret;

  byte_size = round_up_power_of_two (byte_size, sizeof (void *));

  scm_i_pthread_mutex_lock (&admin_mutex);

  while (arena_used + byte_size > arena_size)
    {
      char *new_arena;

      /* See comments in alloc_subr_idx about how we choose 1500 as
         initial size and why we leak the allocation.  */

      if (arena_size)
        arena_size *= 2;
      else
        {
          size_t avg_size = 6 * sizeof(uint32_t);
          avg_size += sizeof(struct scm_jit_function_data);
          arena_size = 1500 * avg_size;
        }

      new_arena = malloc (arena_size);
      memcpy (new_arena, arena, arena_used);
      arena = new_arena;
    }

  ret = arena + arena_used;
  arena_used += byte_size;

  scm_i_pthread_mutex_unlock (&admin_mutex);

  memset (ret, 0, byte_size);

  return ret;
}

static uint32_t *
alloc_primitive_code_with_instrumentation (size_t uint32_count,
                                           uint32_t **write_ptr)
{
  char *ptr;
  uint32_t *ret;
  struct scm_jit_function_data *data;
  size_t byte_size, padded_byte_size;

  /* Reserve space for instrument-entry.  */
  byte_size = (2 + uint32_count) * sizeof (uint32_t);
  padded_byte_size = round_up_power_of_two (byte_size, sizeof (void *));
  /* Reserve space for jit data.  */
  ptr = alloc (padded_byte_size + sizeof (struct scm_jit_function_data));
  ret = (uint32_t *) ptr;
  data = (struct scm_jit_function_data*) (ret + padded_byte_size);

  ret[0] = SCM_PACK_OP_24 (instrument_entry, 0);
  ret[1] = padded_byte_size / 4;

  *write_ptr = ret + 2;

  data->mcode = NULL;
  data->counter = 0;
  data->start = -padded_byte_size;
  data->end = -(padded_byte_size - byte_size);

  return (uint32_t *) ret;
}

static int
is_primitive_code (const void *ptr)
{
  const char *cptr = ptr;
  int ret;

  scm_i_pthread_mutex_lock (&admin_mutex);
  ret = cptr >= arena && (cptr - arena) < arena_used;
  scm_i_pthread_mutex_unlock (&admin_mutex);

  return ret;
}

static uint32_t *
alloc_subr_code (uint32_t subr_idx, uint32_t code[], size_t code_size)
{
  uint32_t post[3] = { SCM_PACK_OP_24 (subr_call, subr_idx),
                       SCM_PACK_OP_24 (handle_interrupts, 0),
                       SCM_PACK_OP_24 (return_values, 0) };
  uint32_t *ret, *write;

  ret = alloc_primitive_code_with_instrumentation (code_size + 3, &write);

  memcpy (write, code, code_size * sizeof (uint32_t));
  write += code_size;
  memcpy (write, post, 3 * sizeof (uint32_t));

  return ret;
}

enum arity_kind {
  NULLARY = 0,
  REQ = 1,
  OPT = 2,
  REST = 4,
  REQ_OPT = REQ + OPT,
  REQ_REST = REQ + REST,
  OPT_REST = OPT + REST,
  REQ_OPT_REST = REQ + OPT + REST
};

static uint32_t*
get_subr_stub_code (uint32_t subr_idx,
                    unsigned int nreq, unsigned int nopt, unsigned int rest)
{
  enum arity_kind kind = NULLARY;

  if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
    scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
      
  if (nreq) kind += REQ;
  if (nopt) kind += OPT;
  if (rest) kind += REST;

  switch (kind)
    {
    case NULLARY:
    case REQ:
      {
        uint32_t code[1] = { SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1) };
        return alloc_subr_code (subr_idx, code, 1);
      }
    case OPT:
      {
        uint32_t code[2] = { SCM_PACK_OP_24 (assert_nargs_le, nopt + 1),
                             SCM_PACK_OP_24 (alloc_frame, nopt + 1) };
        return alloc_subr_code (subr_idx, code, 2);
      }
    case REST:
      {
        uint32_t code[1] = { SCM_PACK_OP_24 (bind_rest, 1) };
        return alloc_subr_code (subr_idx, code, 1);
      }
    case REQ_OPT:
      {
        uint32_t code[3] = { SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1),
                             SCM_PACK_OP_24 (assert_nargs_le, nreq + nopt + 1),
                             SCM_PACK_OP_24 (alloc_frame, nreq + nopt + 1) };
        return alloc_subr_code (subr_idx, code, 3);
      }
    case REQ_REST:
      {
        uint32_t code[2] = { SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1),
                             SCM_PACK_OP_24 (bind_rest, nreq + 1) };
        return alloc_subr_code (subr_idx, code, 2);
      }
    case OPT_REST:
      {
        uint32_t code[1] = { SCM_PACK_OP_24 (bind_rest, nopt + 1) };
        return alloc_subr_code (subr_idx, code, 1);
      }
    case REQ_OPT_REST:
      {
        uint32_t code[2] = { SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1),
                             SCM_PACK_OP_24 (bind_rest, nreq + nopt + 1) };
        return alloc_subr_code (subr_idx, code, 2);
      }
    default:
      abort ();
    }
}

static SCM
create_subr (int define, const char *name,
             unsigned int nreq, unsigned int nopt, unsigned int rest,
             void *fcn, SCM *generic_loc)
{
  SCM ret, sname;
  uint32_t idx;
  scm_t_bits flags;
  scm_t_bits nfree = generic_loc ? 1 : 0;

  idx = alloc_subr_idx (fcn);
  sname = scm_from_utf8_symbol (name);

  flags = SCM_F_PROGRAM_IS_PRIMITIVE;
  flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;

  ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
  SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (idx, nreq, nopt, rest));
  record_subr_name (idx, sname);
  if (generic_loc)
    SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0,
                                   scm_from_pointer (generic_loc, NULL));

  if (define)
    scm_define (sname, ret);

  return ret;
}

int
scm_i_primitive_code_p (const uint32_t *code)
{
  return is_primitive_code (code);
}

static uintptr_t
primitive_call_ip (const uint32_t *code)
{
  int direction = 0;
  while (1)
    {
      switch (code[0] & 0xff)
        {
        case scm_op_instrument_entry:
          if (direction < 0) abort ();
          direction = 1;
          code += 2;
          break;
        case scm_op_assert_nargs_ee:
        case scm_op_assert_nargs_le:
        case scm_op_assert_nargs_ge:
        case scm_op_bind_rest:
        case scm_op_alloc_frame:
          if (direction < 0) abort ();
          direction = 1;
          code += 1;
          break;
        case scm_op_subr_call:
          return (uintptr_t) code;
        case scm_op_return_values:
        case scm_op_handle_interrupts:
          /* Going back isn't possible for instruction streams where we
             don't know the length of the preceding instruction, but for
             the code we emit, these particular opcodes are only ever
             preceded by 4-byte instructions.  */
          if (direction > 0) abort ();
          direction = -1;
          code -= 1;
          break;
        default:
          abort ();
        }
    }
}

static uint32_t
primitive_subr_idx (const uint32_t *code)
{
  uintptr_t call_ip = primitive_call_ip (code);
  uint32_t idx = ((uint32_t *) call_ip)[0] >> 8;
  if (idx >= next_subr_idx) abort();
  return idx;
}

uintptr_t
scm_i_primitive_call_ip (SCM subr)
{
  return primitive_call_ip (SCM_PROGRAM_CODE (subr));
}

SCM
scm_i_primitive_name (const uint32_t *code)
{
  return names[primitive_subr_idx (code)];
}

scm_t_subr
scm_subr_function (SCM subr)
{
  return subrs[primitive_subr_idx (SCM_PROGRAM_CODE (subr))];
}

SCM
scm_subr_name (SCM subr)
{
  return scm_i_primitive_name (SCM_PROGRAM_CODE (subr));
}

SCM
scm_apply_subr (union scm_vm_stack_element *sp, uint32_t idx, ptrdiff_t nslots)
{
  SCM (*subr)() = subrs[idx];

#define ARG(i) (sp[i].as_scm)
  switch (nslots - 1)
    {
    case 0:
      return subr ();
    case 1:
      return subr (ARG (0));
    case 2:
      return subr (ARG (1), ARG (0));
    case 3:
      return subr (ARG (2), ARG (1), ARG (0));
    case 4:
      return subr (ARG (3), ARG (2), ARG (1), ARG (0));
    case 5:
      return subr (ARG (4), ARG (3), ARG (2), ARG (1), ARG (0));
    case 6:
      return subr (ARG (5), ARG (4), ARG (3), ARG (2), ARG (1),
                   ARG (0));
    case 7:
      return subr (ARG (6), ARG (5), ARG (4), ARG (3), ARG (2),
                   ARG (1), ARG (0));
    case 8:
      return subr (ARG (7), ARG (6), ARG (5), ARG (4), ARG (3),
                   ARG (2), ARG (1), ARG (0));
    case 9:
      return subr (ARG (8), ARG (7), ARG (6), ARG (5), ARG (4),
                   ARG (3), ARG (2), ARG (1), ARG (0));
    case 10:
      return subr (ARG (9), ARG (8), ARG (7), ARG (6), ARG (5),
                   ARG (4), ARG (3), ARG (2), ARG (1), ARG (0));
    default:
      abort ();
    }
#undef ARG
}

SCM
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
  return create_subr (0, name, req, opt, rst, fcn, NULL);
}

SCM
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
  return create_subr (1, name, req, opt, rst, fcn, NULL);
}

SCM
scm_c_make_gsubr_with_generic (const char *name,
			       int req,
			       int opt,
			       int rst,
			       SCM (*fcn)(),
			       SCM *gf)
{
  return create_subr (0, name, req, opt, rst, fcn, gf);
}

SCM
scm_c_define_gsubr_with_generic (const char *name,
				 int req,
				 int opt,
				 int rst,
				 SCM (*fcn)(),
				 SCM *gf)
{
  return create_subr (1, name, req, opt, rst, fcn, gf);
}

void
scm_init_gsubr()
{
#include "gsubr.x"
}