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 "foreign.h"
#include "frames.h"
#include "instructions.h"
#include "modules.h"
#include "numbers.h"
#include "private-options.h"
#include "programs.h"
#include "srfi-4.h"
#include "symbols.h"

#include "gsubr.h"


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



/* OK here goes nothing: we're going to define VM assembly trampolines for
   invoking subrs.  Ready?  Right!  */

/* There's a maximum of 10 args, so the number of possible combinations is:
   (REQ-OPT-REST)
   for 0 args: 1 (000) (1 + 0)
   for 1 arg: 3 (100, 010, 001) (2 + 1)
   for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2)
   for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3)
   for N args: 2N+1

   and the index at which N args starts:
   for 0 args: 0
   for 1 args: 1
   for 2 args: 4
   for 3 args: 9
   for N args: N^2

   One can prove this:

   (1 + 3 + 5 + ... + (2N+1))
     = ((2N+1)+1)/2 * (N+1)
     = 2(N+1)/2 * (N+1)
     = (N+1)^2

   Thus the total sum is 11^2 = 121. Let's just generate all of them as
   read-only data.
*/

/* A: req; B: opt; C: rest */
#define A(nreq)                                                         \
  SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1),                           \
  SCM_PACK_OP_24 (subr_call, 0),                                        \
  SCM_PACK_OP_24 (handle_interrupts, 0),                                \
  SCM_PACK_OP_24 (return_values, 0),                                    \
  0,                                                                    \
  0

#define B(nopt)                                                         \
  SCM_PACK_OP_24 (assert_nargs_le, nopt + 1),                           \
  SCM_PACK_OP_24 (alloc_frame, nopt + 1),                               \
  SCM_PACK_OP_24 (subr_call, 0),                                        \
  SCM_PACK_OP_24 (handle_interrupts, 0),                                \
  SCM_PACK_OP_24 (return_values, 0),                                    \
  0

#define C()                                                             \
  SCM_PACK_OP_24 (bind_rest, 1),                                        \
  SCM_PACK_OP_24 (subr_call, 0),                                        \
  SCM_PACK_OP_24 (handle_interrupts, 0),                                \
  SCM_PACK_OP_24 (return_values, 0),                                    \
  0,                                                                    \
  0

#define AB(nreq, nopt)                                                  \
  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),                        \
  SCM_PACK_OP_24 (subr_call, 0),                                        \
  SCM_PACK_OP_24 (handle_interrupts, 0),                                \
  SCM_PACK_OP_24 (return_values, 0)

#define AC(nreq)                                                        \
  SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1),                           \
  SCM_PACK_OP_24 (bind_rest, nreq + 1),                                 \
  SCM_PACK_OP_24 (subr_call, 0),                                        \
  SCM_PACK_OP_24 (handle_interrupts, 0),                                \
  SCM_PACK_OP_24 (return_values, 0),                                    \
  0

#define BC(nopt)                                                        \
  SCM_PACK_OP_24 (bind_rest, nopt + 1),                                 \
  SCM_PACK_OP_24 (subr_call, 0),                                        \
  SCM_PACK_OP_24 (handle_interrupts, 0),                                \
  SCM_PACK_OP_24 (return_values, 0),                                    \
  0,                                                                    \
  0

#define ABC(nreq, nopt)                                                 \
  SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1),                           \
  SCM_PACK_OP_24 (bind_rest, nreq + nopt + 1),                          \
  SCM_PACK_OP_24 (subr_call, 0),                                        \
  SCM_PACK_OP_24 (handle_interrupts, 0),                                \
  SCM_PACK_OP_24 (return_values, 0),                                    \
  0


/*
 (defun generate-bytecode (n)
   "Generate bytecode for N arguments"
   (interactive "p")
   (insert (format "/\* %d arguments *\/\n " n))
   (let ((nreq n))
     (while (<= 0 nreq)
       (let ((nopt (- n nreq)))
         (insert
          (if (< 0 nreq)
              (if (< 0 nopt)
                  (format " AB(%d,%d)," nreq nopt)
                  (format " A(%d)," nreq))
              (if (< 0 nopt)
                  (format " B(%d)," nopt)
                  (format " A(0),"))))
         (setq nreq (1- nreq))))
     (insert "\n ")
     (setq nreq (1- n))
     (while (<= 0 nreq)
       (let ((nopt (- n nreq 1)))
         (insert
          (if (< 0 nreq)
              (if (< 0 nopt)
                  (format " ABC(%d,%d)," nreq nopt)
                  (format " AC(%d)," nreq))
              (if (< 0 nopt)
                  (format " BC(%d)," nopt)
                  (format " C(),"))))
         (setq nreq (1- nreq))))
     (insert "\n\n  ")))

 (defun generate-bytecodes (n)
   "Generate bytecodes for up to N arguments"
   (interactive "p")
   (let ((i 0))
     (while (<= i n)
       (generate-bytecode i)
       (setq i (1+ i)))))
*/
static const scm_t_uint32 subr_stub_code[] = {
  /* C-u 1 0 M-x generate-bytecodes RET */
  /* 0 arguments */
  A(0),

  /* 1 arguments */
  A(1), B(1),
  C(),

  /* 2 arguments */
  A(2), AB(1,1), B(2),
  AC(1), BC(1),

  /* 3 arguments */
  A(3), AB(2,1), AB(1,2), B(3),
  AC(2), ABC(1,1), BC(2),

  /* 4 arguments */
  A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
  AC(3), ABC(2,1), ABC(1,2), BC(3),

  /* 5 arguments */
  A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
  AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),

  /* 6 arguments */
  A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
  AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),

  /* 7 arguments */
  A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
  AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),

  /* 8 arguments */
  A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
  AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),

  /* 9 arguments */
  A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7), AB(1,8), B(9),
  AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6), ABC(1,7), BC(8),

  /* 10 arguments */
  A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7), AB(2,8), AB(1,9), B(10),
  AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6), ABC(2,7), ABC(1,8), BC(9),
};

#undef A
#undef B
#undef C
#undef AB
#undef AC
#undef BC
#undef ABC

/* (nargs * nargs) + nopt + rest * (nargs + 1) */
#define SUBR_STUB_CODE(nreq,nopt,rest)                                \
  &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest)        \
                   + nopt + rest * (nreq + nopt + rest + 1)) * 6]

static const scm_t_uint32*
get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest)
{
  if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
    scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
      
  return SUBR_STUB_CODE (nreq, nopt, rest);
}

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

  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 (nreq, nopt, rest));
  SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL));
  SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname);
  if (generic_loc)
    SCM_PROGRAM_FREE_VARIABLE_SET (ret, 2,
                                       scm_from_pointer (generic_loc, NULL));

  if (define)
    scm_define (sname, ret);

  return ret;
}

int
scm_i_primitive_code_p (const scm_t_uint32 *code)
{
  if (code < subr_stub_code)
    return 0;
  if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
    return 0;

  return 1;
}

scm_t_uintptr
scm_i_primitive_call_ip (SCM subr)
{
  size_t i;
  const scm_t_uint32 *code = SCM_PROGRAM_CODE (subr);

  /* A stub is 6 32-bit words long, or 24 bytes.  The call will be one
     instruction, in either the fourth, third, or second word.  Return a
     byte offset from the entry.  */
  for (i = 1; i < 4; i++)
    if ((code[i] & 0xff) == scm_op_subr_call)
      return (scm_t_uintptr) (code + i);
  abort ();
}

SCM
scm_apply_subr (union scm_vm_stack_element *sp, scm_t_ptrdiff nslots)
{
  SCM (*subr)() = SCM_SUBRF (sp[nslots - 1].as_scm);

#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"
}