1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
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.
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.
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
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"
34 #include "libguile/private-options.h"
38 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
44 /* OK here goes nothing: we're going to define VM assembly trampolines for
45 invoking subrs. Ready? Right! */
47 /* There's a maximum of 10 args, so the number of possible combinations is:
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)
55 and the index at which N args starts:
64 (1 + 3 + 5 + ... + (2N+1))
65 = ((2N+1)+1)/2 * (N+1)
69 Thus the total sum is 11^2 = 121. Let's just generate all of them as
73 /* A: req; B: opt; C: rest */
75 SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \
76 SCM_PACK_OP_24 (subr_call, 0), \
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), \
87 SCM_PACK_OP_24 (bind_rest, 1), \
88 SCM_PACK_OP_24 (subr_call, 0), \
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)
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), \
105 SCM_PACK_OP_24 (bind_rest, nopt + 1), \
106 SCM_PACK_OP_24 (subr_call, 0), \
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), \
118 (defun generate-bytecode (n)
119 "Generate bytecode for N arguments"
121 (insert (format "/\* %d arguments *\/\n " n))
124 (let ((nopt (- n nreq)))
128 (format " AB(%d,%d)," nreq nopt)
129 (format " A(%d)," nreq))
131 (format " B(%d)," nopt)
133 (setq nreq (1- nreq))))
137 (let ((nopt (- n nreq 1)))
141 (format " ABC(%d,%d)," nreq nopt)
142 (format " AC(%d)," nreq))
144 (format " BC(%d)," nopt)
146 (setq nreq (1- nreq))))
149 (defun generate-bytecodes (n)
150 "Generate bytecodes for up to N arguments"
154 (generate-bytecode i)
157 static const scm_t_uint32 subr_stub_code
[] = {
158 /* C-u 1 0 M-x generate-bytecodes RET */
171 A(3), AB(2,1), AB(1,2), B(3),
172 AC(2), ABC(1,1), BC(2),
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),
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),
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),
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),
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),
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),
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),
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]
216 static const scm_t_uint32
*
217 get_subr_stub_code (unsigned int nreq
, unsigned int nopt
, unsigned int rest
)
219 if (SCM_UNLIKELY (rest
> 1 || nreq
+ nopt
+ rest
> 10))
220 scm_out_of_range ("make-subr", scm_from_uint (nreq
+ nopt
+ rest
));
222 return SUBR_STUB_CODE (nreq
, nopt
, rest
);
226 create_subr (int define
, const char *name
,
227 unsigned int nreq
, unsigned int nopt
, unsigned int rest
,
228 SCM (*fcn
) (), SCM
*generic_loc
)
232 scm_t_bits nfree
= generic_loc
? 3 : 2;
234 sname
= scm_from_utf8_symbol (name
);
236 flags
= SCM_F_PROGRAM_IS_PRIMITIVE
;
237 flags
|= generic_loc
? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC
: 0;
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
);
244 SCM_PROGRAM_FREE_VARIABLE_SET (ret
, 2,
245 scm_from_pointer (generic_loc
, NULL
));
248 scm_define (sname
, ret
);
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. */
257 scm_i_primitive_arity (SCM prim
, int *req
, int *opt
, int *rest
)
259 const scm_t_uint32
*code
= SCM_PROGRAM_CODE (prim
);
260 unsigned idx
, nargs
, base
, next
;
262 if (code
< subr_stub_code
)
264 if (code
> subr_stub_code
+ (sizeof(subr_stub_code
) / sizeof(scm_t_uint32
)))
267 idx
= (code
- subr_stub_code
) / 4;
275 next
= (nargs
+ 1) * (nargs
+ 1);
279 *rest
= (next
- idx
) < (idx
- base
);
280 *req
= *rest
? (next
- 1) - idx
: (base
+ nargs
) - idx
;
281 *opt
= *rest
? idx
- (next
- nargs
) : idx
- base
;
287 scm_i_primitive_call_ip (SCM subr
)
289 const scm_t_uint32
*code
= SCM_PROGRAM_CODE (subr
);
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));
298 scm_c_make_gsubr (const char *name
, int req
, int opt
, int rst
, SCM (*fcn
)())
300 return create_subr (0, name
, req
, opt
, rst
, fcn
, NULL
);
304 scm_c_define_gsubr (const char *name
, int req
, int opt
, int rst
, SCM (*fcn
)())
306 return create_subr (1, name
, req
, opt
, rst
, fcn
, NULL
);
310 scm_c_make_gsubr_with_generic (const char *name
,
317 return create_subr (0, name
, req
, opt
, rst
, fcn
, gf
);
321 scm_c_define_gsubr_with_generic (const char *name
,
328 return create_subr (1, name
, req
, opt
, rst
, fcn
, gf
);
334 #include "libguile/gsubr.x"