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