1 /* Copyright (C) 2001, 2008, 2009, 2010, 2011,
2 * 2012 Free Software Foundation, Inc.
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.
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.
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
21 /* This file is included in vm_engine.c */
23 /* Compiler barrier, to prevent instruction reordering, apparently due
24 to a bug in GCC 4.3.2 on sparc-linux-gnu and on hppa2.0-linux-gnu.
25 See <http://bugs.gnu.org/10520>, for details. */
28 # define COMPILER_BARRIER __asm__ __volatile__ ("")
30 # define COMPILER_BARRIER do { } while (0)
39 VM_DEFINE_INSTRUCTION (0, nop
, "nop", 0, 0, 0)
44 VM_DEFINE_INSTRUCTION (1, halt
, "halt", 0, 0, 0)
46 nvalues
= SCM_I_INUM (*sp
--);
55 finish_args
= scm_values (finish_args
);
59 #ifdef VM_ENABLE_STACK_NULLING
63 /* Restore registers */
64 sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
65 /* Setting the ip here doesn't actually affect control flow, as the calling
66 code will restore its own registers, but it does help when walking the
68 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
69 fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
71 NULLSTACK (old_sp
- sp
);
77 VM_DEFINE_INSTRUCTION (2, drop
, "drop", 0, 1, 0)
83 VM_DEFINE_INSTRUCTION (3, dup
, "dup", 0, 0, 1)
95 VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1)
97 PUSH (SCM_UNSPECIFIED
);
101 VM_DEFINE_INSTRUCTION (5, make_true
, "make-true", 0, 0, 1)
107 VM_DEFINE_INSTRUCTION (6, make_false
, "make-false", 0, 0, 1)
113 VM_DEFINE_INSTRUCTION (7, make_nil
, "make-nil", 0, 0, 1)
115 PUSH (SCM_ELISP_NIL
);
119 VM_DEFINE_INSTRUCTION (8, make_eol
, "make-eol", 0, 0, 1)
125 VM_DEFINE_INSTRUCTION (9, make_int8
, "make-int8", 1, 0, 1)
127 PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
131 VM_DEFINE_INSTRUCTION (10, make_int8_0
, "make-int8:0", 0, 0, 1)
137 VM_DEFINE_INSTRUCTION (11, make_int8_1
, "make-int8:1", 0, 0, 1)
139 PUSH (SCM_I_MAKINUM (1));
143 VM_DEFINE_INSTRUCTION (12, make_int16
, "make-int16", 2, 0, 1)
147 PUSH (SCM_I_MAKINUM ((signed short) (h
<< 8) + l
));
151 VM_DEFINE_INSTRUCTION (13, make_int64
, "make-int64", 8, 0, 1)
155 v
<<= 8; v
+= FETCH ();
156 v
<<= 8; v
+= FETCH ();
157 v
<<= 8; v
+= FETCH ();
158 v
<<= 8; v
+= FETCH ();
159 v
<<= 8; v
+= FETCH ();
160 v
<<= 8; v
+= FETCH ();
161 v
<<= 8; v
+= FETCH ();
162 PUSH (scm_from_int64 ((scm_t_int64
) v
));
166 VM_DEFINE_INSTRUCTION (14, make_uint64
, "make-uint64", 8, 0, 1)
170 v
<<= 8; v
+= FETCH ();
171 v
<<= 8; v
+= FETCH ();
172 v
<<= 8; v
+= FETCH ();
173 v
<<= 8; v
+= FETCH ();
174 v
<<= 8; v
+= FETCH ();
175 v
<<= 8; v
+= FETCH ();
176 v
<<= 8; v
+= FETCH ();
177 PUSH (scm_from_uint64 (v
));
181 VM_DEFINE_INSTRUCTION (15, make_char8
, "make-char8", 1, 0, 1)
186 PUSH (SCM_MAKE_CHAR (v
));
187 /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The
188 contents of SCM_MAKE_CHAR may be evaluated more than once,
189 resulting in a double fetch. */
193 VM_DEFINE_INSTRUCTION (16, make_char32
, "make-char32", 4, 0, 1)
197 v
<<= 8; v
+= FETCH ();
198 v
<<= 8; v
+= FETCH ();
199 v
<<= 8; v
+= FETCH ();
200 PUSH (SCM_MAKE_CHAR (v
));
206 VM_DEFINE_INSTRUCTION (17, list
, "list", 2, -1, 1)
208 unsigned h
= FETCH ();
209 unsigned l
= FETCH ();
210 unsigned len
= ((h
<< 8) + l
);
215 VM_DEFINE_INSTRUCTION (18, vector
, "vector", 2, -1, 1)
217 unsigned h
= FETCH ();
218 unsigned l
= FETCH ();
219 unsigned len
= ((h
<< 8) + l
);
225 vect
= scm_make_vector (scm_from_uint (len
), SCM_BOOL_F
);
226 memcpy (SCM_I_VECTOR_WELTS(vect
), sp
, sizeof(SCM
) * len
);
238 #define OBJECT_REF(i) objects[i]
239 #define OBJECT_SET(i,o) objects[i] = o
241 #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
242 #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
244 /* For the variable operations, we _must_ obviously avoid function calls to
245 `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
246 nothing more than the corresponding macros. */
247 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
248 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
249 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
251 #define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
255 VM_DEFINE_INSTRUCTION (19, object_ref
, "object-ref", 1, 0, 1)
257 register unsigned objnum
= FETCH ();
258 CHECK_OBJECT (objnum
);
259 PUSH (OBJECT_REF (objnum
));
263 /* FIXME: necessary? elt 255 of the vector could be a vector... */
264 VM_DEFINE_INSTRUCTION (20, long_object_ref
, "long-object-ref", 2, 0, 1)
266 unsigned int objnum
= FETCH ();
269 CHECK_OBJECT (objnum
);
270 PUSH (OBJECT_REF (objnum
));
274 VM_DEFINE_INSTRUCTION (21, local_ref
, "local-ref", 1, 0, 1)
276 PUSH (LOCAL_REF (FETCH ()));
281 VM_DEFINE_INSTRUCTION (22, long_local_ref
, "long-local-ref", 2, 0, 1)
283 unsigned int i
= FETCH ();
286 PUSH (LOCAL_REF (i
));
291 VM_DEFINE_INSTRUCTION (23, local_bound
, "local-bound?", 1, 0, 1)
293 PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED
)));
297 VM_DEFINE_INSTRUCTION (24, long_local_bound
, "long-local-bound?", 2, 0, 1)
299 unsigned int i
= FETCH ();
302 PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i
), SCM_UNDEFINED
)));
306 VM_DEFINE_INSTRUCTION (25, variable_ref
, "variable-ref", 0, 1, 1)
310 /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because,
311 unlike in top-variable-ref, it really isn't an internal assertion
312 that can be optimized out -- the variable could be coming directly
314 if (SCM_UNLIKELY (!SCM_VARIABLEP (x
)))
316 func_name
= "variable-ref";
318 goto vm_error_not_a_variable
;
320 else if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x
)))
324 /* Attempt to provide the variable name in the error message. */
325 var_name
= scm_module_reverse_lookup (scm_current_module (), x
);
326 finish_args
= scm_is_true (var_name
) ? var_name
: x
;
327 goto vm_error_unbound
;
331 SCM o
= VARIABLE_REF (x
);
338 VM_DEFINE_INSTRUCTION (26, variable_bound
, "variable-bound?", 0, 1, 1)
342 if (SCM_UNLIKELY (!SCM_VARIABLEP (x
)))
344 func_name
= "variable-bound?";
346 goto vm_error_not_a_variable
;
349 *sp
= scm_from_bool (VARIABLE_BOUNDP (x
));
353 VM_DEFINE_INSTRUCTION (27, toplevel_ref
, "toplevel-ref", 1, 0, 1)
355 unsigned objnum
= FETCH ();
357 CHECK_OBJECT (objnum
);
358 what
= OBJECT_REF (objnum
);
360 if (!SCM_VARIABLEP (what
))
363 resolved
= resolve_variable (what
, scm_program_module (program
));
364 if (!VARIABLE_BOUNDP (resolved
))
367 goto vm_error_unbound
;
370 OBJECT_SET (objnum
, what
);
373 PUSH (VARIABLE_REF (what
));
377 VM_DEFINE_INSTRUCTION (28, long_toplevel_ref
, "long-toplevel-ref", 2, 0, 1)
380 unsigned int objnum
= FETCH ();
383 CHECK_OBJECT (objnum
);
384 what
= OBJECT_REF (objnum
);
386 if (!SCM_VARIABLEP (what
))
389 resolved
= resolve_variable (what
, scm_program_module (program
));
390 if (!VARIABLE_BOUNDP (resolved
))
393 goto vm_error_unbound
;
396 OBJECT_SET (objnum
, what
);
399 PUSH (VARIABLE_REF (what
));
405 VM_DEFINE_INSTRUCTION (29, local_set
, "local-set", 1, 1, 0)
409 LOCAL_SET (FETCH (), x
);
413 VM_DEFINE_INSTRUCTION (30, long_local_set
, "long-local-set", 2, 1, 0)
416 unsigned int i
= FETCH ();
424 VM_DEFINE_INSTRUCTION (31, variable_set
, "variable-set", 0, 2, 0)
426 if (SCM_UNLIKELY (!SCM_VARIABLEP (sp
[0])))
428 func_name
= "variable-set!";
430 goto vm_error_not_a_variable
;
432 VARIABLE_SET (sp
[0], sp
[-1]);
437 VM_DEFINE_INSTRUCTION (32, toplevel_set
, "toplevel-set", 1, 1, 0)
439 unsigned objnum
= FETCH ();
441 CHECK_OBJECT (objnum
);
442 what
= OBJECT_REF (objnum
);
444 if (!SCM_VARIABLEP (what
))
447 what
= resolve_variable (what
, scm_program_module (program
));
448 OBJECT_SET (objnum
, what
);
451 VARIABLE_SET (what
, *sp
);
456 VM_DEFINE_INSTRUCTION (33, long_toplevel_set
, "long-toplevel-set", 2, 1, 0)
459 unsigned int objnum
= FETCH ();
462 CHECK_OBJECT (objnum
);
463 what
= OBJECT_REF (objnum
);
465 if (!SCM_VARIABLEP (what
))
468 what
= resolve_variable (what
, scm_program_module (program
));
469 OBJECT_SET (objnum
, what
);
472 VARIABLE_SET (what
, *sp
);
482 /* offset must be at least 24 bits wide, and signed */
483 #define FETCH_OFFSET(offset) \
485 offset = FETCH () << 16; \
486 offset += FETCH () << 8; \
487 offset += FETCH (); \
488 offset -= (offset & (1<<23)) << 1; \
493 scm_t_int32 offset; \
494 FETCH_OFFSET (offset); \
498 VM_HANDLE_INTERRUPTS; \
502 VM_DEFINE_INSTRUCTION (34, br
, "br", 3, 0, 0)
505 FETCH_OFFSET (offset
);
508 VM_HANDLE_INTERRUPTS
;
512 VM_DEFINE_INSTRUCTION (35, br_if
, "br-if", 3, 0, 0)
516 BR (scm_is_true (x
));
519 VM_DEFINE_INSTRUCTION (36, br_if_not
, "br-if-not", 3, 0, 0)
523 BR (scm_is_false (x
));
526 VM_DEFINE_INSTRUCTION (37, br_if_eq
, "br-if-eq", 3, 0, 0)
530 BR (scm_is_eq (x
, y
));
533 VM_DEFINE_INSTRUCTION (38, br_if_not_eq
, "br-if-not-eq", 3, 0, 0)
537 BR (!scm_is_eq (x
, y
));
540 VM_DEFINE_INSTRUCTION (39, br_if_null
, "br-if-null", 3, 0, 0)
544 BR (scm_is_null (x
));
547 VM_DEFINE_INSTRUCTION (40, br_if_not_null
, "br-if-not-null", 3, 0, 0)
551 BR (!scm_is_null (x
));
559 VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne
, "br-if-nargs-ne", 5, 0, 0)
565 FETCH_OFFSET (offset
);
566 if (sp
- (fp
- 1) != n
)
571 VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt
, "br-if-nargs-lt", 5, 0, 0)
577 FETCH_OFFSET (offset
);
578 if (sp
- (fp
- 1) < n
)
583 VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt
, "br-if-nargs-gt", 5, 0, 0)
590 FETCH_OFFSET (offset
);
591 if (sp
- (fp
- 1) > n
)
596 VM_DEFINE_INSTRUCTION (44, assert_nargs_ee
, "assert-nargs-ee", 2, 0, 0)
601 if (sp
- (fp
- 1) != n
)
602 goto vm_error_wrong_num_args
;
606 VM_DEFINE_INSTRUCTION (45, assert_nargs_ge
, "assert-nargs-ge", 2, 0, 0)
611 if (sp
- (fp
- 1) < n
)
612 goto vm_error_wrong_num_args
;
616 VM_DEFINE_INSTRUCTION (46, bind_optionals
, "bind-optionals", 2, -1, -1)
621 while (sp
- (fp
- 1) < n
)
622 PUSH (SCM_UNDEFINED
);
626 VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle
, "bind-optionals/shuffle", 6, -1, -1)
629 scm_t_ptrdiff nreq
, nreq_and_opt
, ntotal
;
630 nreq
= FETCH () << 8;
632 nreq_and_opt
= FETCH () << 8;
633 nreq_and_opt
+= FETCH ();
634 ntotal
= FETCH () << 8;
637 /* look in optionals for first keyword or last positional */
638 /* starting after the last required positional arg */
640 while (/* while we have args */
642 /* and we still have positionals to fill */
643 && walk
- fp
< nreq_and_opt
644 /* and we haven't reached a keyword yet */
645 && !scm_is_keyword (*walk
))
646 /* bind this optional arg (by leaving it in place) */
648 /* now shuffle up, from walk to ntotal */
650 scm_t_ptrdiff nshuf
= sp
- walk
+ 1, i
;
651 sp
= (fp
- 1) + ntotal
+ nshuf
;
653 for (i
= 0; i
< nshuf
; i
++)
654 sp
[-i
] = walk
[nshuf
-i
-1];
656 /* and fill optionals & keyword args with SCM_UNDEFINED */
657 while (walk
<= (fp
- 1) + ntotal
)
658 *walk
++ = SCM_UNDEFINED
;
663 /* Flags that determine whether other keywords are allowed, and whether a
664 rest argument is expected. These values must match those used by the
665 glil->assembly compiler. */
666 #define F_ALLOW_OTHER_KEYS 1
669 VM_DEFINE_INSTRUCTION (48, bind_kwargs
, "bind-kwargs", 5, 0, 0)
673 int kw_and_rest_flags
;
677 /* XXX: We don't actually use NKW. */
680 kw_and_rest_flags
= FETCH ();
682 if (!(kw_and_rest_flags
& F_REST
)
683 && ((sp
- (fp
- 1) - nkw
) % 2))
684 goto vm_error_kwargs_length_not_even
;
687 kw
= OBJECT_REF (idx
);
689 /* Switch NKW to be a negative index below SP. */
690 for (nkw
= -(sp
- (fp
- 1) - nkw
) + 1; nkw
< 0; nkw
++)
694 if (scm_is_keyword (sp
[nkw
]))
696 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
698 if (scm_is_eq (SCM_CAAR (walk
), sp
[nkw
]))
700 SCM si
= SCM_CDAR (walk
);
701 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_long (si
),
706 if (!(kw_and_rest_flags
& F_ALLOW_OTHER_KEYS
) && !scm_is_pair (walk
))
707 goto vm_error_kwargs_unrecognized_keyword
;
711 else if (!(kw_and_rest_flags
& F_REST
))
712 goto vm_error_kwargs_invalid_keyword
;
718 #undef F_ALLOW_OTHER_KEYS
722 VM_DEFINE_INSTRUCTION (49, push_rest
, "push-rest", 2, -1, -1)
728 while (sp
- (fp
- 1) > n
)
729 /* No need to check for underflow. */
730 CONS (rest
, *sp
--, rest
);
735 VM_DEFINE_INSTRUCTION (50, bind_rest
, "bind-rest", 4, -1, -1)
744 while (sp
- (fp
- 1) > n
)
745 /* No need to check for underflow. */
746 CONS (rest
, *sp
--, rest
);
751 VM_DEFINE_INSTRUCTION (51, reserve_locals
, "reserve-locals", 2, -1, -1)
764 *++old_sp
= SCM_UNDEFINED
;
767 NULLSTACK (old_sp
- sp
);
772 VM_DEFINE_INSTRUCTION (52, new_frame
, "new-frame", 0, 0, 3)
774 /* NB: if you change this, see frames.c:vm-frame-num-locals */
775 /* and frames.h, vm-engine.c, etc of course */
777 /* We don't initialize the dynamic link here because we don't actually
778 know that this frame will point to the current fp: it could be
779 placed elsewhere on the stack if captured in a partial
780 continuation, and invoked from some other context. */
781 PUSH (SCM_PACK (0)); /* dynamic link */
782 PUSH (SCM_PACK (0)); /* mvra */
783 PUSH (SCM_PACK (0)); /* ra */
787 VM_DEFINE_INSTRUCTION (53, call
, "call", 1, -1, 1)
792 program
= sp
[-nargs
];
794 VM_HANDLE_INTERRUPTS
;
796 if (SCM_UNLIKELY (!SCM_PROGRAM_P (program
)))
798 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
800 sp
[-nargs
] = SCM_STRUCT_PROCEDURE (program
);
803 else if (SCM_HAS_TYP7 (program
, scm_tc7_smob
)
804 && SCM_SMOB_APPLICABLE_P (program
))
807 sp
[-nargs
] = scm_i_smob_apply_trampoline (program
);
811 goto vm_error_wrong_type_apply
;
821 ASSERT (SCM_FRAME_DYNAMIC_LINK (fp
) == 0);
822 ASSERT (SCM_FRAME_RETURN_ADDRESS (fp
) == 0);
823 ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp
) == 0);
824 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
825 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
);
826 SCM_FRAME_SET_MV_RETURN_ADDRESS (fp
, 0);
829 ip
= SCM_C_OBJCODE_BASE (bp
);
830 PUSH_CONTINUATION_HOOK ();
835 VM_DEFINE_INSTRUCTION (54, tail_call
, "tail-call", 1, -1, 1)
840 program
= sp
[-nargs
];
842 VM_HANDLE_INTERRUPTS
;
844 if (SCM_UNLIKELY (!SCM_PROGRAM_P (program
)))
846 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
848 sp
[-nargs
] = SCM_STRUCT_PROCEDURE (program
);
851 else if (SCM_HAS_TYP7 (program
, scm_tc7_smob
)
852 && SCM_SMOB_APPLICABLE_P (program
))
855 sp
[-nargs
] = scm_i_smob_apply_trampoline (program
);
859 goto vm_error_wrong_type_apply
;
864 #ifdef VM_ENABLE_STACK_NULLING
869 /* switch programs */
871 /* shuffle down the program and the arguments */
872 for (i
= -1, sp
= sp
- nargs
+ 1; i
< nargs
; i
++)
873 SCM_FRAME_STACK_ADDRESS (fp
)[i
] = sp
[i
];
877 NULLSTACK (old_sp
- sp
);
879 ip
= SCM_C_OBJCODE_BASE (bp
);
886 VM_DEFINE_INSTRUCTION (55, subr_call
, "subr-call", 1, -1, -1)
894 subr
= SCM_POINTER_VALUE (pointer
);
896 VM_HANDLE_INTERRUPTS
;
908 ret
= subr (sp
[-1], sp
[0]);
911 ret
= subr (sp
[-2], sp
[-1], sp
[0]);
914 ret
= subr (sp
[-3], sp
[-2], sp
[-1], sp
[0]);
917 ret
= subr (sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
920 ret
= subr (sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
923 ret
= subr (sp
[-6], sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
926 ret
= subr (sp
[-7], sp
[-6], sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
929 ret
= subr (sp
[-8], sp
[-7], sp
[-6], sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
932 ret
= subr (sp
[-9], sp
[-8], sp
[-7], sp
[-6], sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
938 NULLSTACK_FOR_NONLOCAL_EXIT ();
940 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
942 /* multiple values returned to continuation */
943 ret
= scm_struct_ref (ret
, SCM_INUM0
);
944 nvalues
= scm_ilength (ret
);
945 PUSH_LIST (ret
, scm_is_null
);
946 goto vm_return_values
;
955 VM_DEFINE_INSTRUCTION (56, smob_call
, "smob-call", 1, -1, -1)
962 subr
= SCM_SMOB_DESCRIPTOR (smob
).apply
;
964 VM_HANDLE_INTERRUPTS
;
973 ret
= subr (smob
, sp
[0]);
976 ret
= subr (smob
, sp
[-1], sp
[0]);
979 ret
= subr (smob
, sp
[-2], sp
[-1], sp
[0]);
985 NULLSTACK_FOR_NONLOCAL_EXIT ();
987 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
989 /* multiple values returned to continuation */
990 ret
= scm_struct_ref (ret
, SCM_INUM0
);
991 nvalues
= scm_ilength (ret
);
992 PUSH_LIST (ret
, scm_is_null
);
993 goto vm_return_values
;
1002 VM_DEFINE_INSTRUCTION (57, foreign_call
, "foreign-call", 1, -1, -1)
1008 VM_HANDLE_INTERRUPTS
;
1011 ret
= scm_i_foreign_call (foreign
, sp
- nargs
+ 1);
1013 NULLSTACK_FOR_NONLOCAL_EXIT ();
1015 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1017 /* multiple values returned to continuation */
1018 ret
= scm_struct_ref (ret
, SCM_INUM0
);
1019 nvalues
= scm_ilength (ret
);
1020 PUSH_LIST (ret
, scm_is_null
);
1021 goto vm_return_values
;
1030 VM_DEFINE_INSTRUCTION (58, continuation_call
, "continuation-call", 0, -1, 0)
1036 scm_i_check_continuation (contregs
);
1037 vm_return_to_continuation (scm_i_contregs_vm (contregs
),
1038 scm_i_contregs_vm_cont (contregs
),
1040 scm_i_reinstate_continuation (contregs
);
1046 VM_DEFINE_INSTRUCTION (59, partial_cont_call
, "partial-cont-call", 0, -1, 0)
1048 SCM vmcont
, intwinds
, prevwinds
;
1049 POP2 (intwinds
, vmcont
);
1051 if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont
)))
1052 { finish_args
= vmcont
;
1053 goto vm_error_continuation_not_rewindable
;
1055 prevwinds
= scm_i_dynwinds ();
1056 vm_reinstate_partial_continuation (vm
, vmcont
, intwinds
, sp
+ 1 - fp
, fp
,
1059 /* Rewind prompt jmpbuffers, if any. */
1061 SCM winds
= scm_i_dynwinds ();
1062 for (; !scm_is_eq (winds
, prevwinds
); winds
= scm_cdr (winds
))
1063 if (SCM_PROMPT_P (scm_car (winds
)) && SCM_PROMPT_SETJMP (scm_car (winds
)))
1068 program
= SCM_FRAME_PROGRAM (fp
);
1073 VM_DEFINE_INSTRUCTION (60, tail_call_nargs
, "tail-call/nargs", 0, 0, 1)
1077 nargs
= scm_to_int (x
);
1078 /* FIXME: should truncate values? */
1082 VM_DEFINE_INSTRUCTION (61, call_nargs
, "call/nargs", 0, 0, 1)
1086 nargs
= scm_to_int (x
);
1087 /* FIXME: should truncate values? */
1091 VM_DEFINE_INSTRUCTION (62, mv_call
, "mv-call", 4, -1, 1)
1097 FETCH_OFFSET (offset
);
1101 program
= sp
[-nargs
];
1103 VM_HANDLE_INTERRUPTS
;
1105 if (SCM_UNLIKELY (!SCM_PROGRAM_P (program
)))
1107 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
1109 sp
[-nargs
] = SCM_STRUCT_PROCEDURE (program
);
1112 else if (SCM_HAS_TYP7 (program
, scm_tc7_smob
)
1113 && SCM_SMOB_APPLICABLE_P (program
))
1116 sp
[-nargs
] = scm_i_smob_apply_trampoline (program
);
1120 goto vm_error_wrong_type_apply
;
1128 fp
= sp
- nargs
+ 1;
1130 ASSERT (SCM_FRAME_DYNAMIC_LINK (fp
) == 0);
1131 ASSERT (SCM_FRAME_RETURN_ADDRESS (fp
) == 0);
1132 ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp
) == 0);
1133 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
1134 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
);
1135 SCM_FRAME_SET_MV_RETURN_ADDRESS (fp
, mvra
);
1138 ip
= SCM_C_OBJCODE_BASE (bp
);
1139 PUSH_CONTINUATION_HOOK ();
1144 VM_DEFINE_INSTRUCTION (63, apply
, "apply", 1, -1, 1)
1151 ASSERT (nargs
>= 2);
1153 len
= scm_ilength (ls
);
1154 if (SCM_UNLIKELY (len
< 0))
1157 goto vm_error_apply_to_non_list
;
1160 PUSH_LIST (ls
, SCM_NULL_OR_NIL_P
);
1166 VM_DEFINE_INSTRUCTION (64, tail_apply
, "tail-apply", 1, -1, 1)
1173 ASSERT (nargs
>= 2);
1175 len
= scm_ilength (ls
);
1176 if (SCM_UNLIKELY (len
< 0))
1179 goto vm_error_apply_to_non_list
;
1182 PUSH_LIST (ls
, SCM_NULL_OR_NIL_P
);
1188 VM_DEFINE_INSTRUCTION (65, call_cc
, "call/cc", 0, 1, 1)
1191 SCM proc
, vm_cont
, cont
;
1194 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
, fp
, sp
, ip
, NULL
, 0);
1195 cont
= scm_i_make_continuation (&first
, vm
, vm_cont
);
1198 PUSH (SCM_PACK (0)); /* dynamic link */
1199 PUSH (SCM_PACK (0)); /* mvra */
1200 PUSH (SCM_PACK (0)); /* ra */
1208 /* Otherwise, the vm continuation was reinstated, and
1209 vm_return_to_continuation pushed on one value. We know only one
1210 value was returned because we are in value context -- the
1211 previous block jumped to vm_call, not vm_mv_call, after all.
1213 So, pull our regs back down from the vp, and march on to the
1214 next instruction. */
1216 program
= SCM_FRAME_PROGRAM (fp
);
1218 RESTORE_CONTINUATION_HOOK ();
1223 VM_DEFINE_INSTRUCTION (66, tail_call_cc
, "tail-call/cc", 0, 1, 1)
1226 SCM proc
, vm_cont
, cont
;
1229 /* In contrast to call/cc, tail-call/cc captures the continuation without the
1231 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
1232 SCM_FRAME_DYNAMIC_LINK (fp
),
1233 SCM_FRAME_LOWER_ADDRESS (fp
) - 1,
1234 SCM_FRAME_RETURN_ADDRESS (fp
),
1235 SCM_FRAME_MV_RETURN_ADDRESS (fp
),
1237 cont
= scm_i_make_continuation (&first
, vm
, vm_cont
);
1247 /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
1248 does a return from the frame, either to the RA or
1251 program
= SCM_FRAME_PROGRAM (fp
);
1253 /* Unfortunately we don't know whether we are at the RA, and thus
1254 have one value without an nvalues marker, or we are at the
1255 MVRA and thus have multiple values and the nvalues
1256 marker. Instead of adding heuristics here, we will let hook
1257 client code do that. */
1258 RESTORE_CONTINUATION_HOOK ();
1263 VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
1266 POP_CONTINUATION_HOOK (1);
1268 VM_HANDLE_INTERRUPTS
;
1275 #ifdef VM_ENABLE_STACK_NULLING
1279 /* Restore registers */
1280 sp
= SCM_FRAME_LOWER_ADDRESS (fp
);
1281 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
1282 fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1285 #ifdef VM_ENABLE_STACK_NULLING
1286 NULLSTACK (old_sp
- sp
);
1289 /* Set return value (sp is already pushed) */
1293 /* Restore the last program */
1294 program
= SCM_FRAME_PROGRAM (fp
);
1300 VM_DEFINE_INSTRUCTION (68, return_values
, "return/values", 1, -1, -1)
1302 /* nvalues declared at top level, because for some reason gcc seems to think
1303 that perhaps it might be used without declaration. Fooey to that, I say. */
1306 POP_CONTINUATION_HOOK (nvalues
);
1308 VM_HANDLE_INTERRUPTS
;
1310 if (nvalues
!= 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp
))
1312 /* A multiply-valued continuation */
1313 SCM
*vals
= sp
- nvalues
;
1315 /* Restore registers */
1316 sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
1317 ip
= SCM_FRAME_MV_RETURN_ADDRESS (fp
);
1318 fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1321 /* Push return values, and the number of values */
1322 for (i
= 0; i
< nvalues
; i
++)
1324 *++sp
= SCM_I_MAKINUM (nvalues
);
1326 /* Finally null the end of the stack */
1327 NULLSTACK (vals
+ nvalues
- sp
);
1329 else if (nvalues
>= 1)
1331 /* Multiple values for a single-valued continuation -- here's where I
1332 break with guile tradition and try and do something sensible. (Also,
1333 this block handles the single-valued return to an mv
1335 SCM
*vals
= sp
- nvalues
;
1336 /* Restore registers */
1337 sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
1338 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
1339 fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1342 /* Push first value */
1345 /* Finally null the end of the stack */
1346 NULLSTACK (vals
+ nvalues
- sp
);
1349 goto vm_error_no_values
;
1351 /* Restore the last program */
1352 program
= SCM_FRAME_PROGRAM (fp
);
1358 VM_DEFINE_INSTRUCTION (69, return_values_star
, "return/values*", 1, -1, -1)
1363 ASSERT (nvalues
>= 1);
1367 while (scm_is_pair (l
))
1373 if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l
))) {
1374 finish_args
= scm_list_1 (l
);
1375 goto vm_error_improper_list
;
1378 goto vm_return_values
;
1381 VM_DEFINE_INSTRUCTION (70, return_nvalues
, "return/nvalues", 0, 1, -1)
1385 nvalues
= scm_to_int (n
);
1386 ASSERT (nvalues
>= 0);
1387 goto vm_return_values
;
1390 VM_DEFINE_INSTRUCTION (71, truncate_values
, "truncate-values", 2, -1, -1)
1395 nvalues
= scm_to_int (x
);
1402 if (nvalues
< nbinds
)
1403 goto vm_error_not_enough_values
;
1406 POP_LIST (nvalues
- nbinds
);
1408 DROPN (nvalues
- nbinds
);
1413 VM_DEFINE_INSTRUCTION (72, box
, "box", 1, 1, 0)
1418 LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable
, SCM_UNPACK (val
)));
1423 (let ((a *undef*) (b *undef*) ...)
1424 (set! a (lambda () (b ...)))
1427 VM_DEFINE_INSTRUCTION (73, empty_box
, "empty-box", 1, 0, 0)
1430 LOCAL_SET (FETCH (),
1431 scm_cell (scm_tc7_variable
, SCM_UNPACK (SCM_UNDEFINED
)));
1435 VM_DEFINE_INSTRUCTION (74, local_boxed_ref
, "local-boxed-ref", 1, 0, 1)
1437 SCM v
= LOCAL_REF (FETCH ());
1438 ASSERT_BOUND_VARIABLE (v
);
1439 PUSH (VARIABLE_REF (v
));
1443 VM_DEFINE_INSTRUCTION (75, local_boxed_set
, "local-boxed-set", 1, 1, 0)
1446 v
= LOCAL_REF (FETCH ());
1448 ASSERT_VARIABLE (v
);
1449 VARIABLE_SET (v
, val
);
1453 VM_DEFINE_INSTRUCTION (76, free_ref
, "free-ref", 1, 0, 1)
1455 scm_t_uint8 idx
= FETCH ();
1457 CHECK_FREE_VARIABLE (idx
);
1458 PUSH (FREE_VARIABLE_REF (idx
));
1462 /* no free-set -- if a var is assigned, it should be in a box */
1464 VM_DEFINE_INSTRUCTION (77, free_boxed_ref
, "free-boxed-ref", 1, 0, 1)
1467 scm_t_uint8 idx
= FETCH ();
1468 CHECK_FREE_VARIABLE (idx
);
1469 v
= FREE_VARIABLE_REF (idx
);
1470 ASSERT_BOUND_VARIABLE (v
);
1471 PUSH (VARIABLE_REF (v
));
1475 VM_DEFINE_INSTRUCTION (78, free_boxed_set
, "free-boxed-set", 1, 1, 0)
1478 scm_t_uint8 idx
= FETCH ();
1480 CHECK_FREE_VARIABLE (idx
);
1481 v
= FREE_VARIABLE_REF (idx
);
1482 ASSERT_BOUND_VARIABLE (v
);
1483 VARIABLE_SET (v
, val
);
1487 VM_DEFINE_INSTRUCTION (79, make_closure
, "make-closure", 2, -1, 1)
1496 closure
= scm_words (scm_tc7_program
| (len
<<16), len
+ 3);
1497 SCM_SET_CELL_OBJECT_1 (closure
, SCM_PROGRAM_OBJCODE (sp
[-len
]));
1498 SCM_SET_CELL_OBJECT_2 (closure
, SCM_PROGRAM_OBJTABLE (sp
[-len
]));
1500 for (n
= 0; n
< len
; n
++)
1501 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, sp
[-len
+ 1 + n
]);
1506 VM_DEFINE_INSTRUCTION (80, make_variable
, "make-variable", 0, 0, 1)
1509 /* fixme underflow */
1510 PUSH (scm_cell (scm_tc7_variable
, SCM_UNPACK (SCM_UNDEFINED
)));
1514 VM_DEFINE_INSTRUCTION (81, fix_closure
, "fix-closure", 2, -1, 0)
1517 unsigned int i
= FETCH ();
1521 /* FIXME CHECK_LOCAL (i) */
1523 /* FIXME ASSERT_PROGRAM (x); */
1524 len
= SCM_PROGRAM_NUM_FREE_VARIABLES (x
);
1525 for (n
= 0; n
< len
; n
++)
1526 SCM_PROGRAM_FREE_VARIABLE_SET (x
, n
, sp
[-len
+ 1 + n
]);
1531 VM_DEFINE_INSTRUCTION (82, define
, "define", 0, 0, 2)
1536 VARIABLE_SET (scm_sym2var (sym
, scm_current_module_lookup_closure (),
1542 VM_DEFINE_INSTRUCTION (83, make_keyword
, "make-keyword", 0, 1, 1)
1546 *sp
= scm_symbol_to_keyword (*sp
);
1550 VM_DEFINE_INSTRUCTION (84, make_symbol
, "make-symbol", 0, 1, 1)
1554 *sp
= scm_string_to_symbol (*sp
);
1558 VM_DEFINE_INSTRUCTION (85, prompt
, "prompt", 4, 2, 0)
1561 scm_t_uint8 escape_only_p
;
1564 escape_only_p
= FETCH ();
1565 FETCH_OFFSET (offset
);
1569 /* Push the prompt onto the dynamic stack. */
1570 prompt
= scm_c_make_prompt (k
, fp
, sp
, ip
+ offset
, escape_only_p
, vm_cookie
,
1572 scm_i_set_dynwinds (scm_cons (prompt
, SCM_PROMPT_DYNWINDS (prompt
)));
1573 if (SCM_PROMPT_SETJMP (prompt
))
1575 /* The prompt exited nonlocally. Cache the regs back from the vp, and go
1578 Note, at this point, we must assume that any variable local to
1579 vm_engine that can be assigned *has* been assigned. So we need to pull
1580 all our state back from the ip/fp/sp.
1583 program
= SCM_FRAME_PROGRAM (fp
);
1585 /* The stack contains the values returned to this prompt, along
1586 with a number-of-values marker -- like an MV return. */
1587 ABORT_CONTINUATION_HOOK ();
1591 /* Otherwise setjmp returned for the first time, so we go to execute the
1596 VM_DEFINE_INSTRUCTION (86, wind
, "wind", 0, 2, 0)
1599 POP2 (unwind
, wind
);
1601 /* Push wind and unwind procedures onto the dynamic stack. Note that neither
1602 are actually called; the compiler should emit calls to wind and unwind for
1603 the normal dynamic-wind control flow. */
1604 if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind
))))
1607 goto vm_error_not_a_thunk
;
1609 if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind
))))
1611 finish_args
= unwind
;
1612 goto vm_error_not_a_thunk
;
1614 scm_i_set_dynwinds (scm_cons (scm_cons (wind
, unwind
), scm_i_dynwinds ()));
1618 VM_DEFINE_INSTRUCTION (87, abort
, "abort", 1, -1, -1)
1620 unsigned n
= FETCH ();
1622 if (sp
- n
- 2 <= SCM_FRAME_UPPER_ADDRESS (fp
))
1623 goto vm_error_stack_underflow
;
1624 vm_abort (vm
, n
, vm_cookie
);
1625 /* vm_abort should not return */
1629 VM_DEFINE_INSTRUCTION (88, unwind
, "unwind", 0, 0, 0)
1631 /* A normal exit from the dynamic extent of an expression. Pop the top entry
1632 off of the dynamic stack. */
1633 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1637 VM_DEFINE_INSTRUCTION (89, wind_fluids
, "wind-fluids", 1, -1, 0)
1639 unsigned n
= FETCH ();
1645 wf
= scm_i_make_with_fluids (n
, sp
+ 1, sp
+ 1 + n
);
1648 scm_i_swap_with_fluids (wf
, current_thread
->dynamic_state
);
1649 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
1653 VM_DEFINE_INSTRUCTION (90, unwind_fluids
, "unwind-fluids", 0, 0, 0)
1656 wf
= scm_car (scm_i_dynwinds ());
1657 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1658 scm_i_swap_with_fluids (wf
, current_thread
->dynamic_state
);
1662 VM_DEFINE_INSTRUCTION (91, fluid_ref
, "fluid-ref", 0, 1, 1)
1668 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
1669 if (SCM_UNLIKELY (!SCM_FLUID_P (*sp
))
1670 || ((num
= SCM_I_FLUID_NUM (*sp
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
1672 /* Punt dynstate expansion and error handling to the C proc. */
1674 *sp
= scm_fluid_ref (*sp
);
1678 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
1679 if (scm_is_eq (val
, SCM_UNDEFINED
))
1680 val
= SCM_I_FLUID_DEFAULT (*sp
);
1681 if (SCM_UNLIKELY (scm_is_eq (val
, SCM_UNDEFINED
)))
1684 goto vm_error_unbound_fluid
;
1692 VM_DEFINE_INSTRUCTION (92, fluid_set
, "fluid-set", 0, 2, 0)
1695 SCM val
, fluid
, fluids
;
1698 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
1699 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
1700 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
1702 /* Punt dynstate expansion and error handling to the C proc. */
1704 scm_fluid_set_x (fluid
, val
);
1707 SCM_SIMPLE_VECTOR_SET (fluids
, num
, val
);
1712 VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals
, "assert-nargs-ee/locals", 1, 0, 0)
1717 /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
1720 if (SCM_UNLIKELY (sp
- (fp
- 1) != (n
& 0x7)))
1721 goto vm_error_wrong_num_args
;
1727 *++old_sp
= SCM_UNDEFINED
;
1732 #undef COMPILER_BARRIER
1735 (defun renumber-ops ()
1736 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1739 (let ((counter -1)) (goto-char (point-min))
1740 (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1742 (number-to-string (setq counter (1+ counter)))