libguile/gsubr.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include <stdio.h>
  25 #include <stdarg.h>
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/gsubr.h"
  29 #include "libguile/foreign.h"
  30 #include "libguile/instructions.h"
  31 #include "libguile/objcodes.h"
  32 #include "libguile/srfi-4.h"
  33 #include "libguile/programs.h"
  34
  35 #include "libguile/private-options.h"
  36 \f
  37 /*
  38  * gsubr.c
  39  * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
  40  * and rest arguments.
  41  */
  42
  43 \f
  44
  45 /* OK here goes nothing: we're going to define VM assembly trampolines for
  46    invoking subrs, along with their meta-information, and then wrap them into
  47    statically allocated objcode values. Ready? Right!
  48 */
  49
  50 /* There's a maximum of 10 args, so the number of possible combinations is:
  51    (REQ-OPT-REST)
  52    for 0 args: 1 (000) (1 + 0)
  53    for 1 arg: 3 (100, 010, 001) (2 + 1)
  54    for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2)
  55    for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3)
  56    for N args: 2N+1
  57
  58    and the index at which N args starts:
  59    for 0 args: 0
  60    for 1 args: 1
  61    for 2 args: 4
  62    for 3 args: 9
  63    for N args: N^2
  64
  65    One can prove this:
  66
  67    (1 + 3 + 5 + ... + (2N+1))
  68      = ((2N+1)+1)/2 * (N+1)
  69      = 2(N+1)/2 * (N+1)
  70      = (N+1)^2
  71
  72    Thus the total sum is 11^2 = 121. Let's just generate all of them as
  73    read-only data.
  74 */
  75
  76 /* A: req; B: opt; C: rest */
  77 #define A(nreq)                                                         \
  78   SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, nreq + 1),               \
  79   SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
  80   0,                                                                    \
  81   0
  82
  83 #define B(nopt)                                                         \
  84   SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nopt + 1),               \
  85   SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nopt + 1),                   \
  86   SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
  87   0
  88
  89 #define C()                                                             \
  90   SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, 1),                            \
  91   SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
  92   0,                                                                    \
  93   0
  94
  95 #define AB(nreq, nopt)                                                  \
  96   SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1),               \
  97   SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nreq + nopt + 1),        \
  98   SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nreq + nopt + 1),            \
  99   SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0)
 100
 101 #define AC(nreq)                                                        \
 102   SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1),               \
 103   SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + 1),                     \
 104   SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
 105   0
 106
 107 #define BC(nopt)                                                        \
 108   SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nopt + 1),                     \
 109   SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
 110   0,                                                                    \
 111   0
 112
 113 #define ABC(nreq, nopt)                                                 \
 114   SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1),               \
 115   SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + nopt + 1),              \
 116   SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0),                            \
 117   0
 118
 119
 120 /*
 121  (defun generate-bytecode (n)
 122    "Generate bytecode for N arguments"
 123    (interactive "p")
 124    (insert (format "/\* %d arguments *\/\n " n))
 125    (let ((nreq n))
 126      (while (<= 0 nreq)
 127        (let ((nopt (- n nreq)))
 128          (insert
 129           (if (< 0 nreq)
 130               (if (< 0 nopt)
 131                   (format " AB(%d,%d)," nreq nopt)
 132                   (format " A(%d)," nreq))
 133               (if (< 0 nopt)
 134                   (format " B(%d)," nopt)
 135                   (format " A(0),"))))
 136          (setq nreq (1- nreq))))
 137      (insert "\n ")
 138      (setq nreq (1- n))
 139      (while (<= 0 nreq)
 140        (let ((nopt (- n nreq 1)))
 141          (insert
 142           (if (< 0 nreq)
 143               (if (< 0 nopt)
 144                   (format " ABC(%d,%d)," nreq nopt)
 145                   (format " AC(%d)," nreq))
 146               (if (< 0 nopt)
 147                   (format " BC(%d)," nopt)
 148                   (format " C(),"))))
 149          (setq nreq (1- nreq))))
 150      (insert "\n\n  ")))
 151
 152  (defun generate-bytecodes (n)
 153    "Generate bytecodes for up to N arguments"
 154    (interactive "p")
 155    (let ((i 0))
 156      (while (<= i n)
 157        (generate-bytecode i)
 158        (setq i (1+ i)))))
 159 */
 160 static const scm_t_uint32 subr_stub_code[] = {
 161   /* C-u 1 0 M-x generate-bytecodes RET */
 162   /* 0 arguments */
 163   A(0),
 164
 165   /* 1 arguments */
 166   A(1), B(1),
 167   C(),
 168
 169   /* 2 arguments */
 170   A(2), AB(1,1), B(2),
 171   AC(1), BC(1),
 172
 173   /* 3 arguments */
 174   A(3), AB(2,1), AB(1,2), B(3),
 175   AC(2), ABC(1,1), BC(2),
 176
 177   /* 4 arguments */
 178   A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
 179   AC(3), ABC(2,1), ABC(1,2), BC(3),
 180
 181   /* 5 arguments */
 182   A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
 183   AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
 184
 185   /* 6 arguments */
 186   A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
 187   AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
 188
 189   /* 7 arguments */
 190   A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
 191   AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
 192
 193   /* 8 arguments */
 194   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),
 195   AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
 196
 197   /* 9 arguments */
 198   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),
 199   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),
 200
 201   /* 10 arguments */
 202   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),
 203   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),
 204 };
 205
 206 #undef A
 207 #undef B
 208 #undef C
 209 #undef AB
 210 #undef AC
 211 #undef BC
 212 #undef ABC
 213
 214 /* (nargs * nargs) + nopt + rest * (nargs + 1) */
 215 #define SUBR_STUB_CODE(nreq,nopt,rest)                                \
 216   &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest)        \
 217                    + nopt + rest * (nreq + nopt + rest + 1)) * 4]
 218
 219 static const scm_t_uint32*
 220 get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest)
 221 {
 222   if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
 223     scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
 224
 225   return SUBR_STUB_CODE (nreq, nopt, rest);
 226 }
 227
 228 static SCM
 229 create_subr (int define, const char *name,
 230              unsigned int nreq, unsigned int nopt, unsigned int rest,
 231              SCM (*fcn) (), SCM *generic_loc)
 232 {
 233   SCM ret, sname;
 234   scm_t_bits flags;
 235   scm_t_bits nfree = generic_loc ? 3 : 2;
 236
 237   sname = scm_from_utf8_symbol (name);
 238
 239   flags = SCM_F_PROGRAM_IS_PRIMITIVE;
 240   flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
 241
 242   ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
 243   SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest));
 244   SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL));
 245   SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname);
 246   if (generic_loc)
 247     SCM_PROGRAM_FREE_VARIABLE_SET (ret, 2,
 248                                        scm_from_pointer (generic_loc, NULL));
 249
 250   if (define)
 251     scm_define (sname, ret);
 252
 253   return ret;
 254 }
 255
 256 /* Given an RTL primitive, determine its minimum arity.  This is
 257    possible because each RTL primitive is 4 32-bit words long, and they
 258    are laid out contiguously in an ordered pattern.  */
 259 int
 260 scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest)
 261 {
 262   const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim);
 263   unsigned idx, nargs, base, next;
 264
 265   if (code < subr_stub_code)
 266     return 0;
 267   if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
 268     return 0;
 269
 270   idx = (code - subr_stub_code) / 4;
 271
 272   nargs = -1;
 273   next = 0;
 274   do
 275     {
 276       base = next;
 277       nargs++;
 278       next = (nargs + 1) * (nargs + 1);
 279     }
 280   while (idx >= next);
 281
 282   *rest = (next - idx) < (idx - base);
 283   *req = *rest ? (next - 1) - idx : (base + nargs) - idx;
 284   *opt = *rest ? idx - (next - nargs) : idx - base;
 285
 286   return 1;
 287 }
 288
 289 scm_t_uintptr
 290 scm_i_primitive_call_ip (SCM subr)
 291 {
 292   const scm_t_uint32 *code = SCM_PROGRAM_CODE (subr);
 293
 294   /* A stub is 4 32-bit words long, or 16 bytes.  The call will be one
 295      instruction, in either the fourth, third, or second word.  Return a
 296      byte offset from the entry.  */
 297   return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1));
 298 }
 299
 300 SCM
 301 scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 302 {
 303   return create_subr (0, name, req, opt, rst, fcn, NULL);
 304 }
 305
 306 SCM
 307 scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 308 {
 309   return create_subr (1, name, req, opt, rst, fcn, NULL);
 310 }
 311
 312 SCM
 313 scm_c_make_gsubr_with_generic (const char *name,
 314                                int req,
 315                                int opt,
 316                                int rst,
 317                                SCM (*fcn)(),
 318                                SCM *gf)
 319 {
 320   return create_subr (0, name, req, opt, rst, fcn, gf);
 321 }
 322
 323 SCM
 324 scm_c_define_gsubr_with_generic (const char *name,
 325                                  int req,
 326                                  int opt,
 327                                  int rst,
 328                                  SCM (*fcn)(),
 329                                  SCM *gf)
 330 {
 331   return create_subr (1, name, req, opt, rst, fcn, gf);
 332 }
 333
 334 void
 335 scm_init_gsubr()
 336 {
 337 #include "libguile/gsubr.x"
 338 }
 339
 340 /*
 341   Local Variables:
 342   c-file-style: "gnu"
 343   End:
 344 */