libguile/gsubr.c

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