1 /* Copyright (C) 2001,2008,2009,2010 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
20 /* This file is included in vm_engine.c */
27 VM_DEFINE_INSTRUCTION (0, nop
, "nop", 0, 0, 0)
32 VM_DEFINE_INSTRUCTION (1, halt
, "halt", 0, 0, 0)
34 nvalues
= SCM_I_INUM (*sp
--);
43 finish_args
= scm_values (finish_args
);
47 #ifdef VM_ENABLE_STACK_NULLING
51 /* Restore registers */
52 sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
53 /* Setting the ip here doesn't actually affect control flow, as the calling
54 code will restore its own registers, but it does help when walking the
56 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
57 fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
58 NULLSTACK (old_sp
- sp
);
64 VM_DEFINE_INSTRUCTION (2, drop
, "drop", 0, 1, 0)
70 VM_DEFINE_INSTRUCTION (3, dup
, "dup", 0, 0, 1)
82 VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1)
84 PUSH (SCM_UNSPECIFIED
);
88 VM_DEFINE_INSTRUCTION (5, make_true
, "make-true", 0, 0, 1)
94 VM_DEFINE_INSTRUCTION (6, make_false
, "make-false", 0, 0, 1)
100 VM_DEFINE_INSTRUCTION (7, make_nil
, "make-nil", 0, 0, 1)
102 PUSH (SCM_ELISP_NIL
);
106 VM_DEFINE_INSTRUCTION (8, make_eol
, "make-eol", 0, 0, 1)
112 VM_DEFINE_INSTRUCTION (9, make_int8
, "make-int8", 1, 0, 1)
114 PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
118 VM_DEFINE_INSTRUCTION (10, make_int8_0
, "make-int8:0", 0, 0, 1)
124 VM_DEFINE_INSTRUCTION (11, make_int8_1
, "make-int8:1", 0, 0, 1)
126 PUSH (SCM_I_MAKINUM (1));
130 VM_DEFINE_INSTRUCTION (12, make_int16
, "make-int16", 2, 0, 1)
134 PUSH (SCM_I_MAKINUM ((signed short) (h
<< 8) + l
));
138 VM_DEFINE_INSTRUCTION (13, make_int64
, "make-int64", 8, 0, 1)
142 v
<<= 8; v
+= FETCH ();
143 v
<<= 8; v
+= FETCH ();
144 v
<<= 8; v
+= FETCH ();
145 v
<<= 8; v
+= FETCH ();
146 v
<<= 8; v
+= FETCH ();
147 v
<<= 8; v
+= FETCH ();
148 v
<<= 8; v
+= FETCH ();
149 PUSH (scm_from_int64 ((scm_t_int64
) v
));
153 VM_DEFINE_INSTRUCTION (14, make_uint64
, "make-uint64", 8, 0, 1)
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 v
<<= 8; v
+= FETCH ();
163 v
<<= 8; v
+= FETCH ();
164 PUSH (scm_from_uint64 (v
));
168 VM_DEFINE_INSTRUCTION (15, make_char8
, "make-char8", 1, 0, 1)
173 PUSH (SCM_MAKE_CHAR (v
));
174 /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The
175 contents of SCM_MAKE_CHAR may be evaluated more than once,
176 resulting in a double fetch. */
180 VM_DEFINE_INSTRUCTION (16, make_char32
, "make-char32", 4, 0, 1)
184 v
<<= 8; v
+= FETCH ();
185 v
<<= 8; v
+= FETCH ();
186 v
<<= 8; v
+= FETCH ();
187 PUSH (SCM_MAKE_CHAR (v
));
193 VM_DEFINE_INSTRUCTION (17, list
, "list", 2, -1, 1)
195 unsigned h
= FETCH ();
196 unsigned l
= FETCH ();
197 unsigned len
= ((h
<< 8) + l
);
202 VM_DEFINE_INSTRUCTION (18, vector
, "vector", 2, -1, 1)
204 unsigned h
= FETCH ();
205 unsigned l
= FETCH ();
206 unsigned len
= ((h
<< 8) + l
);
212 vect
= scm_make_vector (scm_from_uint (len
), SCM_BOOL_F
);
213 memcpy (SCM_I_VECTOR_WELTS(vect
), sp
, sizeof(SCM
) * len
);
225 #define OBJECT_REF(i) objects[i]
226 #define OBJECT_SET(i,o) objects[i] = o
228 #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
229 #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
231 /* For the variable operations, we _must_ obviously avoid function calls to
232 `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
233 nothing more than the corresponding macros. */
234 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
235 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
236 #define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED)
238 #define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
242 VM_DEFINE_INSTRUCTION (19, object_ref
, "object-ref", 1, 0, 1)
244 register unsigned objnum
= FETCH ();
245 CHECK_OBJECT (objnum
);
246 PUSH (OBJECT_REF (objnum
));
250 /* FIXME: necessary? elt 255 of the vector could be a vector... */
251 VM_DEFINE_INSTRUCTION (20, long_object_ref
, "long-object-ref", 2, 0, 1)
253 unsigned int objnum
= FETCH ();
256 CHECK_OBJECT (objnum
);
257 PUSH (OBJECT_REF (objnum
));
261 VM_DEFINE_INSTRUCTION (21, local_ref
, "local-ref", 1, 0, 1)
263 PUSH (LOCAL_REF (FETCH ()));
268 VM_DEFINE_INSTRUCTION (22, long_local_ref
, "long-local-ref", 2, 0, 1)
270 unsigned int i
= FETCH ();
273 PUSH (LOCAL_REF (i
));
278 VM_DEFINE_INSTRUCTION (23, local_bound
, "local-bound?", 1, 0, 1)
280 if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED
)
287 VM_DEFINE_INSTRUCTION (24, long_local_bound
, "long-local-bound?", 2, 0, 1)
289 unsigned int i
= FETCH ();
292 if (LOCAL_REF (i
) == SCM_UNDEFINED
)
299 VM_DEFINE_INSTRUCTION (25, variable_ref
, "variable-ref", 0, 1, 1)
303 if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x
)))
307 /* Attempt to provide the variable name in the error message. */
308 var_name
= scm_module_reverse_lookup (scm_current_module (), x
);
309 finish_args
= scm_is_true (var_name
) ? var_name
: x
;
310 goto vm_error_unbound
;
314 SCM o
= VARIABLE_REF (x
);
321 VM_DEFINE_INSTRUCTION (26, variable_bound
, "variable-bound?", 0, 1, 1)
323 if (VARIABLE_BOUNDP (*sp
))
330 VM_DEFINE_INSTRUCTION (27, toplevel_ref
, "toplevel-ref", 1, 0, 1)
332 unsigned objnum
= FETCH ();
334 CHECK_OBJECT (objnum
);
335 what
= OBJECT_REF (objnum
);
337 if (!SCM_VARIABLEP (what
))
340 resolved
= resolve_variable (what
, scm_program_module (program
));
341 if (!VARIABLE_BOUNDP (resolved
))
344 goto vm_error_unbound
;
347 OBJECT_SET (objnum
, what
);
350 PUSH (VARIABLE_REF (what
));
354 VM_DEFINE_INSTRUCTION (28, long_toplevel_ref
, "long-toplevel-ref", 2, 0, 1)
357 unsigned int objnum
= FETCH ();
360 CHECK_OBJECT (objnum
);
361 what
= OBJECT_REF (objnum
);
363 if (!SCM_VARIABLEP (what
))
366 resolved
= resolve_variable (what
, scm_program_module (program
));
367 if (!VARIABLE_BOUNDP (resolved
))
370 goto vm_error_unbound
;
373 OBJECT_SET (objnum
, what
);
376 PUSH (VARIABLE_REF (what
));
382 VM_DEFINE_INSTRUCTION (29, local_set
, "local-set", 1, 1, 0)
384 LOCAL_SET (FETCH (), *sp
);
389 VM_DEFINE_INSTRUCTION (30, long_local_set
, "long-local-set", 2, 1, 0)
391 unsigned int i
= FETCH ();
399 VM_DEFINE_INSTRUCTION (31, variable_set
, "variable-set", 0, 2, 0)
401 VARIABLE_SET (sp
[0], sp
[-1]);
406 VM_DEFINE_INSTRUCTION (32, toplevel_set
, "toplevel-set", 1, 1, 0)
408 unsigned objnum
= FETCH ();
410 CHECK_OBJECT (objnum
);
411 what
= OBJECT_REF (objnum
);
413 if (!SCM_VARIABLEP (what
))
416 what
= resolve_variable (what
, scm_program_module (program
));
417 OBJECT_SET (objnum
, what
);
420 VARIABLE_SET (what
, *sp
);
425 VM_DEFINE_INSTRUCTION (33, long_toplevel_set
, "long-toplevel-set", 2, 1, 0)
428 unsigned int objnum
= FETCH ();
431 CHECK_OBJECT (objnum
);
432 what
= OBJECT_REF (objnum
);
434 if (!SCM_VARIABLEP (what
))
437 what
= resolve_variable (what
, scm_program_module (program
));
438 OBJECT_SET (objnum
, what
);
441 VARIABLE_SET (what
, *sp
);
451 /* offset must be at least 24 bits wide, and signed */
452 #define FETCH_OFFSET(offset) \
454 offset = FETCH () << 16; \
455 offset += FETCH () << 8; \
456 offset += FETCH (); \
457 offset -= (offset & (1<<23)) << 1; \
462 scm_t_int32 offset; \
463 FETCH_OFFSET (offset); \
467 VM_HANDLE_INTERRUPTS; \
473 VM_DEFINE_INSTRUCTION (34, br
, "br", 3, 0, 0)
476 FETCH_OFFSET (offset
);
479 VM_HANDLE_INTERRUPTS
;
483 VM_DEFINE_INSTRUCTION (35, br_if
, "br-if", 3, 0, 0)
485 BR (scm_is_true (*sp
));
488 VM_DEFINE_INSTRUCTION (36, br_if_not
, "br-if-not", 3, 0, 0)
490 BR (scm_is_false (*sp
));
493 VM_DEFINE_INSTRUCTION (37, br_if_eq
, "br-if-eq", 3, 0, 0)
495 sp
--; /* underflow? */
496 BR (scm_is_eq (sp
[0], sp
[1]));
499 VM_DEFINE_INSTRUCTION (38, br_if_not_eq
, "br-if-not-eq", 3, 0, 0)
501 sp
--; /* underflow? */
502 BR (!scm_is_eq (sp
[0], sp
[1]));
505 VM_DEFINE_INSTRUCTION (39, br_if_null
, "br-if-null", 3, 0, 0)
507 BR (scm_is_null (*sp
));
510 VM_DEFINE_INSTRUCTION (40, br_if_not_null
, "br-if-not-null", 3, 0, 0)
512 BR (!scm_is_null (*sp
));
520 VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne
, "br-if-nargs-ne", 5, 0, 0)
526 FETCH_OFFSET (offset
);
527 if (sp
- (fp
- 1) != n
)
532 VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt
, "br-if-nargs-lt", 5, 0, 0)
538 FETCH_OFFSET (offset
);
539 if (sp
- (fp
- 1) < n
)
544 VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt
, "br-if-nargs-gt", 5, 0, 0)
551 FETCH_OFFSET (offset
);
552 if (sp
- (fp
- 1) > n
)
557 VM_DEFINE_INSTRUCTION (44, assert_nargs_ee
, "assert-nargs-ee", 2, 0, 0)
562 if (sp
- (fp
- 1) != n
)
563 goto vm_error_wrong_num_args
;
567 VM_DEFINE_INSTRUCTION (45, assert_nargs_ge
, "assert-nargs-ge", 2, 0, 0)
572 if (sp
- (fp
- 1) < n
)
573 goto vm_error_wrong_num_args
;
577 VM_DEFINE_INSTRUCTION (46, bind_optionals
, "bind-optionals", 2, -1, -1)
582 while (sp
- (fp
- 1) < n
)
583 PUSH (SCM_UNDEFINED
);
587 VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle
, "bind-optionals/shuffle", 6, -1, -1)
590 scm_t_ptrdiff nreq
, nreq_and_opt
, ntotal
;
591 nreq
= FETCH () << 8;
593 nreq_and_opt
= FETCH () << 8;
594 nreq_and_opt
+= FETCH ();
595 ntotal
= FETCH () << 8;
598 /* look in optionals for first keyword or last positional */
599 /* starting after the last required positional arg */
601 while (/* while we have args */
603 /* and we still have positionals to fill */
604 && walk
- fp
< nreq_and_opt
605 /* and we haven't reached a keyword yet */
606 && !scm_is_keyword (*walk
))
607 /* bind this optional arg (by leaving it in place) */
609 /* now shuffle up, from walk to ntotal */
611 scm_t_ptrdiff nshuf
= sp
- walk
+ 1, i
;
612 sp
= (fp
- 1) + ntotal
+ nshuf
;
614 for (i
= 0; i
< nshuf
; i
++)
615 sp
[-i
] = walk
[nshuf
-i
-1];
617 /* and fill optionals & keyword args with SCM_UNDEFINED */
618 while (walk
<= (fp
- 1) + ntotal
)
619 *walk
++ = SCM_UNDEFINED
;
624 /* Flags that determine whether other keywords are allowed, and whether a
625 rest argument is expected. These values must match those used by the
626 glil->assembly compiler. */
627 #define F_ALLOW_OTHER_KEYS 1
630 VM_DEFINE_INSTRUCTION (48, bind_kwargs
, "bind-kwargs", 5, 0, 0)
634 int kw_and_rest_flags
;
638 /* XXX: We don't actually use NKW. */
641 kw_and_rest_flags
= FETCH ();
643 if (!(kw_and_rest_flags
& F_REST
)
644 && ((sp
- (fp
- 1) - nkw
) % 2))
645 goto vm_error_kwargs_length_not_even
;
648 kw
= OBJECT_REF (idx
);
650 /* Switch NKW to be a negative index below SP. */
651 for (nkw
= -(sp
- (fp
- 1) - nkw
) + 1; nkw
< 0; nkw
++)
655 if (scm_is_keyword (sp
[nkw
]))
657 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
659 if (scm_is_eq (SCM_CAAR (walk
), sp
[nkw
]))
661 SCM si
= SCM_CDAR (walk
);
662 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_long (si
),
667 if (!(kw_and_rest_flags
& F_ALLOW_OTHER_KEYS
) && !scm_is_pair (walk
))
668 goto vm_error_kwargs_unrecognized_keyword
;
672 else if (!(kw_and_rest_flags
& F_REST
))
673 goto vm_error_kwargs_invalid_keyword
;
679 #undef F_ALLOW_OTHER_KEYS
683 VM_DEFINE_INSTRUCTION (49, push_rest
, "push-rest", 2, -1, -1)
689 while (sp
- (fp
- 1) > n
)
690 /* No need to check for underflow. */
691 CONS (rest
, *sp
--, rest
);
696 VM_DEFINE_INSTRUCTION (50, bind_rest
, "bind-rest", 4, -1, -1)
705 while (sp
- (fp
- 1) > n
)
706 /* No need to check for underflow. */
707 CONS (rest
, *sp
--, rest
);
712 VM_DEFINE_INSTRUCTION (51, reserve_locals
, "reserve-locals", 2, -1, -1)
725 *++old_sp
= SCM_UNDEFINED
;
728 NULLSTACK (old_sp
- sp
);
733 VM_DEFINE_INSTRUCTION (52, new_frame
, "new-frame", 0, 0, 3)
735 /* NB: if you change this, see frames.c:vm-frame-num-locals */
736 /* and frames.h, vm-engine.c, etc of course */
737 PUSH ((SCM
)fp
); /* dynamic link */
743 VM_DEFINE_INSTRUCTION (53, call
, "call", 1, -1, 1)
748 program
= sp
[-nargs
];
750 VM_HANDLE_INTERRUPTS
;
752 if (SCM_UNLIKELY (!SCM_PROGRAM_P (program
)))
754 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
756 sp
[-nargs
] = SCM_STRUCT_PROCEDURE (program
);
759 else if (SCM_NIMP (program
) && SCM_TYP7 (program
) == scm_tc7_smob
760 && SCM_SMOB_APPLICABLE_P (program
))
763 sp
[-nargs
] = scm_i_smob_apply_trampoline (program
);
767 goto vm_error_wrong_type_apply
;
772 ASSERT (SCM_FRAME_RETURN_ADDRESS (fp
) == 0);
773 ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp
) == 0);
774 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
);
775 SCM_FRAME_SET_MV_RETURN_ADDRESS (fp
, 0);
776 ip
= SCM_C_OBJCODE_BASE (bp
);
777 PUSH_CONTINUATION_HOOK ();
782 VM_DEFINE_INSTRUCTION (54, tail_call
, "tail-call", 1, -1, 1)
787 program
= sp
[-nargs
];
789 VM_HANDLE_INTERRUPTS
;
791 if (SCM_UNLIKELY (!SCM_PROGRAM_P (program
)))
793 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
795 sp
[-nargs
] = SCM_STRUCT_PROCEDURE (program
);
798 else if (SCM_NIMP (program
) && SCM_TYP7 (program
) == scm_tc7_smob
799 && SCM_SMOB_APPLICABLE_P (program
))
802 sp
[-nargs
] = scm_i_smob_apply_trampoline (program
);
806 goto vm_error_wrong_type_apply
;
811 #ifdef VM_ENABLE_STACK_NULLING
816 /* switch programs */
818 /* shuffle down the program and the arguments */
819 for (i
= -1, sp
= sp
- nargs
+ 1; i
< nargs
; i
++)
820 SCM_FRAME_STACK_ADDRESS (fp
)[i
] = sp
[i
];
824 NULLSTACK (old_sp
- sp
);
826 ip
= SCM_C_OBJCODE_BASE (bp
);
833 VM_DEFINE_INSTRUCTION (55, subr_call
, "subr-call", 1, -1, -1)
841 subr
= SCM_POINTER_VALUE (pointer
);
843 VM_HANDLE_INTERRUPTS
;
855 ret
= subr (sp
[-1], sp
[0]);
858 ret
= subr (sp
[-2], sp
[-1], sp
[0]);
861 ret
= subr (sp
[-3], sp
[-2], sp
[-1], sp
[0]);
864 ret
= subr (sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
867 ret
= subr (sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
870 ret
= subr (sp
[-6], sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
873 ret
= subr (sp
[-7], sp
[-6], sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
876 ret
= subr (sp
[-8], sp
[-7], sp
[-6], sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
879 ret
= subr (sp
[-9], sp
[-8], sp
[-7], sp
[-6], sp
[-5], sp
[-4], sp
[-3], sp
[-2], sp
[-1], sp
[0]);
885 NULLSTACK_FOR_NONLOCAL_EXIT ();
887 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
889 /* multiple values returned to continuation */
890 ret
= scm_struct_ref (ret
, SCM_INUM0
);
891 nvalues
= scm_ilength (ret
);
892 PUSH_LIST (ret
, scm_is_null
);
893 goto vm_return_values
;
902 VM_DEFINE_INSTRUCTION (56, smob_call
, "smob-call", 1, -1, -1)
909 subr
= SCM_SMOB_DESCRIPTOR (smob
).apply
;
911 VM_HANDLE_INTERRUPTS
;
920 ret
= subr (smob
, sp
[0]);
923 ret
= subr (smob
, sp
[-1], sp
[0]);
926 ret
= subr (smob
, sp
[-2], sp
[-1], sp
[0]);
932 NULLSTACK_FOR_NONLOCAL_EXIT ();
934 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
936 /* multiple values returned to continuation */
937 ret
= scm_struct_ref (ret
, SCM_INUM0
);
938 nvalues
= scm_ilength (ret
);
939 PUSH_LIST (ret
, scm_is_null
);
940 goto vm_return_values
;
949 VM_DEFINE_INSTRUCTION (57, foreign_call
, "foreign-call", 1, -1, -1)
955 VM_HANDLE_INTERRUPTS
;
958 ret
= scm_i_foreign_call (foreign
, sp
- nargs
+ 1);
960 NULLSTACK_FOR_NONLOCAL_EXIT ();
962 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
964 /* multiple values returned to continuation */
965 ret
= scm_struct_ref (ret
, SCM_INUM0
);
966 nvalues
= scm_ilength (ret
);
967 PUSH_LIST (ret
, scm_is_null
);
968 goto vm_return_values
;
977 VM_DEFINE_INSTRUCTION (58, continuation_call
, "continuation-call", 0, -1, 0)
983 scm_i_check_continuation (contregs
);
984 vm_return_to_continuation (scm_i_contregs_vm (contregs
),
985 scm_i_contregs_vm_cont (contregs
),
987 scm_i_reinstate_continuation (contregs
);
993 VM_DEFINE_INSTRUCTION (59, partial_cont_call
, "partial-cont-call", 0, -1, 0)
995 SCM vmcont
, intwinds
, prevwinds
;
999 if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont
)))
1000 { finish_args
= vmcont
;
1001 goto vm_error_continuation_not_rewindable
;
1003 prevwinds
= scm_i_dynwinds ();
1004 vm_reinstate_partial_continuation (vm
, vmcont
, intwinds
, sp
+ 1 - fp
, fp
,
1007 /* Rewind prompt jmpbuffers, if any. */
1009 SCM winds
= scm_i_dynwinds ();
1010 for (; !scm_is_eq (winds
, prevwinds
); winds
= scm_cdr (winds
))
1011 if (SCM_PROMPT_P (scm_car (winds
)) && SCM_PROMPT_SETJMP (scm_car (winds
)))
1016 program
= SCM_FRAME_PROGRAM (fp
);
1021 VM_DEFINE_INSTRUCTION (60, tail_call_nargs
, "tail-call/nargs", 0, 0, 1)
1025 nargs
= scm_to_int (x
);
1026 /* FIXME: should truncate values? */
1030 VM_DEFINE_INSTRUCTION (61, call_nargs
, "call/nargs", 0, 0, 1)
1034 nargs
= scm_to_int (x
);
1035 /* FIXME: should truncate values? */
1039 VM_DEFINE_INSTRUCTION (62, mv_call
, "mv-call", 4, -1, 1)
1045 FETCH_OFFSET (offset
);
1049 program
= sp
[-nargs
];
1051 VM_HANDLE_INTERRUPTS
;
1053 if (SCM_UNLIKELY (!SCM_PROGRAM_P (program
)))
1055 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
1057 sp
[-nargs
] = SCM_STRUCT_PROCEDURE (program
);
1060 else if (SCM_NIMP (program
) && SCM_TYP7 (program
) == scm_tc7_smob
1061 && SCM_SMOB_APPLICABLE_P (program
))
1064 sp
[-nargs
] = scm_i_smob_apply_trampoline (program
);
1068 goto vm_error_wrong_type_apply
;
1072 fp
= sp
- nargs
+ 1;
1073 ASSERT (SCM_FRAME_RETURN_ADDRESS (fp
) == 0);
1074 ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp
) == 0);
1075 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
);
1076 SCM_FRAME_SET_MV_RETURN_ADDRESS (fp
, mvra
);
1077 ip
= SCM_C_OBJCODE_BASE (bp
);
1078 PUSH_CONTINUATION_HOOK ();
1083 VM_DEFINE_INSTRUCTION (63, apply
, "apply", 1, -1, 1)
1090 ASSERT (nargs
>= 2);
1092 len
= scm_ilength (ls
);
1093 if (SCM_UNLIKELY (len
< 0))
1096 goto vm_error_apply_to_non_list
;
1099 PUSH_LIST (ls
, SCM_NULL_OR_NIL_P
);
1105 VM_DEFINE_INSTRUCTION (64, tail_apply
, "tail-apply", 1, -1, 1)
1112 ASSERT (nargs
>= 2);
1114 len
= scm_ilength (ls
);
1115 if (SCM_UNLIKELY (len
< 0))
1118 goto vm_error_apply_to_non_list
;
1121 PUSH_LIST (ls
, SCM_NULL_OR_NIL_P
);
1127 VM_DEFINE_INSTRUCTION (65, call_cc
, "call/cc", 0, 1, 1)
1130 SCM proc
, vm_cont
, cont
;
1133 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
, fp
, sp
, ip
, NULL
, 0);
1134 cont
= scm_i_make_continuation (&first
, vm
, vm_cont
);
1137 PUSH ((SCM
)fp
); /* dynamic link */
1138 PUSH (0); /* mvra */
1147 /* Otherwise, the vm continuation was reinstated, and
1148 vm_return_to_continuation pushed on one value. We know only one
1149 value was returned because we are in value context -- the
1150 previous block jumped to vm_call, not vm_mv_call, after all.
1152 So, pull our regs back down from the vp, and march on to the
1153 next instruction. */
1155 program
= SCM_FRAME_PROGRAM (fp
);
1157 RESTORE_CONTINUATION_HOOK ();
1162 VM_DEFINE_INSTRUCTION (66, tail_call_cc
, "tail-call/cc", 0, 1, 1)
1165 SCM proc
, vm_cont
, cont
;
1168 /* In contrast to call/cc, tail-call/cc captures the continuation without the
1170 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
1171 SCM_FRAME_DYNAMIC_LINK (fp
),
1172 SCM_FRAME_LOWER_ADDRESS (fp
) - 1,
1173 SCM_FRAME_RETURN_ADDRESS (fp
),
1174 SCM_FRAME_MV_RETURN_ADDRESS (fp
),
1176 cont
= scm_i_make_continuation (&first
, vm
, vm_cont
);
1186 /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
1187 does a return from the frame, either to the RA or
1190 program
= SCM_FRAME_PROGRAM (fp
);
1192 /* Unfortunately we don't know whether we are at the RA, and thus
1193 have one value without an nvalues marker, or we are at the
1194 MVRA and thus have multiple values and the nvalues
1195 marker. Instead of adding heuristics here, we will let hook
1196 client code do that. */
1197 RESTORE_CONTINUATION_HOOK ();
1202 VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
1205 POP_CONTINUATION_HOOK (1);
1207 VM_HANDLE_INTERRUPTS
;
1214 #ifdef VM_ENABLE_STACK_NULLING
1218 /* Restore registers */
1219 sp
= SCM_FRAME_LOWER_ADDRESS (fp
);
1220 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
1221 fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1223 #ifdef VM_ENABLE_STACK_NULLING
1224 NULLSTACK (old_sp
- sp
);
1227 /* Set return value (sp is already pushed) */
1231 /* Restore the last program */
1232 program
= SCM_FRAME_PROGRAM (fp
);
1238 VM_DEFINE_INSTRUCTION (68, return_values
, "return/values", 1, -1, -1)
1240 /* nvalues declared at top level, because for some reason gcc seems to think
1241 that perhaps it might be used without declaration. Fooey to that, I say. */
1244 POP_CONTINUATION_HOOK (nvalues
);
1246 VM_HANDLE_INTERRUPTS
;
1248 if (nvalues
!= 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp
))
1250 /* A multiply-valued continuation */
1251 SCM
*vals
= sp
- nvalues
;
1253 /* Restore registers */
1254 sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
1255 ip
= SCM_FRAME_MV_RETURN_ADDRESS (fp
);
1256 fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1258 /* Push return values, and the number of values */
1259 for (i
= 0; i
< nvalues
; i
++)
1261 *++sp
= SCM_I_MAKINUM (nvalues
);
1263 /* Finally null the end of the stack */
1264 NULLSTACK (vals
+ nvalues
- sp
);
1266 else if (nvalues
>= 1)
1268 /* Multiple values for a single-valued continuation -- here's where I
1269 break with guile tradition and try and do something sensible. (Also,
1270 this block handles the single-valued return to an mv
1272 SCM
*vals
= sp
- nvalues
;
1273 /* Restore registers */
1274 sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
1275 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
1276 fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1278 /* Push first value */
1281 /* Finally null the end of the stack */
1282 NULLSTACK (vals
+ nvalues
- sp
);
1285 goto vm_error_no_values
;
1287 /* Restore the last program */
1288 program
= SCM_FRAME_PROGRAM (fp
);
1294 VM_DEFINE_INSTRUCTION (69, return_values_star
, "return/values*", 1, -1, -1)
1299 ASSERT (nvalues
>= 1);
1303 while (scm_is_pair (l
))
1309 if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l
))) {
1310 finish_args
= scm_list_1 (l
);
1311 goto vm_error_improper_list
;
1314 goto vm_return_values
;
1317 VM_DEFINE_INSTRUCTION (70, return_nvalues
, "return/nvalues", 0, 1, -1)
1321 nvalues
= scm_to_int (n
);
1322 ASSERT (nvalues
>= 0);
1323 goto vm_return_values
;
1326 VM_DEFINE_INSTRUCTION (71, truncate_values
, "truncate-values", 2, -1, -1)
1331 nvalues
= scm_to_int (x
);
1338 if (nvalues
< nbinds
)
1339 goto vm_error_not_enough_values
;
1342 POP_LIST (nvalues
- nbinds
);
1344 DROPN (nvalues
- nbinds
);
1349 VM_DEFINE_INSTRUCTION (72, box
, "box", 1, 1, 0)
1354 LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable
, SCM_UNPACK (val
)));
1359 (let ((a *undef*) (b *undef*) ...)
1360 (set! a (lambda () (b ...)))
1363 VM_DEFINE_INSTRUCTION (73, empty_box
, "empty-box", 1, 0, 0)
1366 LOCAL_SET (FETCH (),
1367 scm_cell (scm_tc7_variable
, SCM_UNPACK (SCM_UNDEFINED
)));
1371 VM_DEFINE_INSTRUCTION (74, local_boxed_ref
, "local-boxed-ref", 1, 0, 1)
1373 SCM v
= LOCAL_REF (FETCH ());
1374 ASSERT_BOUND_VARIABLE (v
);
1375 PUSH (VARIABLE_REF (v
));
1379 VM_DEFINE_INSTRUCTION (75, local_boxed_set
, "local-boxed-set", 1, 1, 0)
1382 v
= LOCAL_REF (FETCH ());
1384 ASSERT_VARIABLE (v
);
1385 VARIABLE_SET (v
, val
);
1389 VM_DEFINE_INSTRUCTION (76, free_ref
, "free-ref", 1, 0, 1)
1391 scm_t_uint8 idx
= FETCH ();
1393 CHECK_FREE_VARIABLE (idx
);
1394 PUSH (FREE_VARIABLE_REF (idx
));
1398 /* no free-set -- if a var is assigned, it should be in a box */
1400 VM_DEFINE_INSTRUCTION (77, free_boxed_ref
, "free-boxed-ref", 1, 0, 1)
1403 scm_t_uint8 idx
= FETCH ();
1404 CHECK_FREE_VARIABLE (idx
);
1405 v
= FREE_VARIABLE_REF (idx
);
1406 ASSERT_BOUND_VARIABLE (v
);
1407 PUSH (VARIABLE_REF (v
));
1411 VM_DEFINE_INSTRUCTION (78, free_boxed_set
, "free-boxed-set", 1, 1, 0)
1414 scm_t_uint8 idx
= FETCH ();
1416 CHECK_FREE_VARIABLE (idx
);
1417 v
= FREE_VARIABLE_REF (idx
);
1418 ASSERT_BOUND_VARIABLE (v
);
1419 VARIABLE_SET (v
, val
);
1423 VM_DEFINE_INSTRUCTION (79, make_closure
, "make-closure", 2, -1, 1)
1432 closure
= scm_words (scm_tc7_program
| (len
<<16), len
+ 3);
1433 SCM_SET_CELL_OBJECT_1 (closure
, SCM_PROGRAM_OBJCODE (sp
[-len
]));
1434 SCM_SET_CELL_OBJECT_2 (closure
, SCM_PROGRAM_OBJTABLE (sp
[-len
]));
1436 for (n
= 0; n
< len
; n
++)
1437 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, sp
[-len
+ 1 + n
]);
1442 VM_DEFINE_INSTRUCTION (80, make_variable
, "make-variable", 0, 0, 1)
1445 /* fixme underflow */
1446 PUSH (scm_cell (scm_tc7_variable
, SCM_UNPACK (SCM_UNDEFINED
)));
1450 VM_DEFINE_INSTRUCTION (81, fix_closure
, "fix-closure", 2, -1, 0)
1453 unsigned int i
= FETCH ();
1457 /* FIXME CHECK_LOCAL (i) */
1459 /* FIXME ASSERT_PROGRAM (x); */
1460 len
= SCM_PROGRAM_NUM_FREE_VARIABLES (x
);
1461 for (n
= 0; n
< len
; n
++)
1462 SCM_PROGRAM_FREE_VARIABLE_SET (x
, n
, sp
[-len
+ 1 + n
]);
1467 VM_DEFINE_INSTRUCTION (82, define
, "define", 0, 0, 2)
1473 VARIABLE_SET (scm_sym2var (sym
, scm_current_module_lookup_closure (),
1479 VM_DEFINE_INSTRUCTION (83, make_keyword
, "make-keyword", 0, 1, 1)
1483 *sp
= scm_symbol_to_keyword (*sp
);
1487 VM_DEFINE_INSTRUCTION (84, make_symbol
, "make-symbol", 0, 1, 1)
1491 *sp
= scm_string_to_symbol (*sp
);
1495 VM_DEFINE_INSTRUCTION (85, prompt
, "prompt", 4, 2, 0)
1498 scm_t_uint8 escape_only_p
;
1501 escape_only_p
= FETCH ();
1502 FETCH_OFFSET (offset
);
1506 /* Push the prompt onto the dynamic stack. */
1507 prompt
= scm_c_make_prompt (k
, fp
, sp
, ip
+ offset
, escape_only_p
, vm_cookie
,
1509 scm_i_set_dynwinds (scm_cons (prompt
, SCM_PROMPT_DYNWINDS (prompt
)));
1510 if (SCM_PROMPT_SETJMP (prompt
))
1512 /* The prompt exited nonlocally. Cache the regs back from the vp, and go
1515 Note, at this point, we must assume that any variable local to
1516 vm_engine that can be assigned *has* been assigned. So we need to pull
1517 all our state back from the ip/fp/sp.
1520 program
= SCM_FRAME_PROGRAM (fp
);
1522 /* The stack contains the values returned to this prompt, along
1523 with a number-of-values marker -- like an MV return. */
1524 ABORT_CONTINUATION_HOOK ();
1528 /* Otherwise setjmp returned for the first time, so we go to execute the
1533 VM_DEFINE_INSTRUCTION (86, wind
, "wind", 0, 2, 0)
1539 /* Push wind and unwind procedures onto the dynamic stack. Note that neither
1540 are actually called; the compiler should emit calls to wind and unwind for
1541 the normal dynamic-wind control flow. */
1542 if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind
))))
1545 goto vm_error_not_a_thunk
;
1547 if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind
))))
1549 finish_args
= unwind
;
1550 goto vm_error_not_a_thunk
;
1552 scm_i_set_dynwinds (scm_cons (scm_cons (wind
, unwind
), scm_i_dynwinds ()));
1556 VM_DEFINE_INSTRUCTION (87, abort
, "abort", 1, -1, -1)
1558 unsigned n
= FETCH ();
1560 if (sp
- n
- 2 <= SCM_FRAME_UPPER_ADDRESS (fp
))
1561 goto vm_error_stack_underflow
;
1562 vm_abort (vm
, n
, vm_cookie
);
1563 /* vm_abort should not return */
1567 VM_DEFINE_INSTRUCTION (88, unwind
, "unwind", 0, 0, 0)
1569 /* A normal exit from the dynamic extent of an expression. Pop the top entry
1570 off of the dynamic stack. */
1571 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1575 VM_DEFINE_INSTRUCTION (89, wind_fluids
, "wind-fluids", 1, -1, 0)
1577 unsigned n
= FETCH ();
1583 wf
= scm_i_make_with_fluids (n
, sp
+ 1, sp
+ 1 + n
);
1586 scm_i_swap_with_fluids (wf
, dynstate
);
1587 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
1591 VM_DEFINE_INSTRUCTION (90, unwind_fluids
, "unwind-fluids", 0, 0, 0)
1594 wf
= scm_car (scm_i_dynwinds ());
1595 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1596 scm_i_swap_with_fluids (wf
, dynstate
);
1600 VM_DEFINE_INSTRUCTION (91, fluid_ref
, "fluid-ref", 0, 1, 1)
1606 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (dynstate
);
1607 if (SCM_UNLIKELY (!SCM_FLUID_P (*sp
))
1608 || ((num
= SCM_I_FLUID_NUM (*sp
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
1610 /* Punt dynstate expansion and error handling to the C proc. */
1612 *sp
= scm_fluid_ref (*sp
);
1616 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
1617 if (SCM_UNLIKELY (val
== SCM_UNDEFINED
))
1620 goto vm_error_unbound_fluid
;
1628 VM_DEFINE_INSTRUCTION (92, fluid_set
, "fluid-set", 0, 2, 0)
1631 SCM val
, fluid
, fluids
;
1635 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (dynstate
);
1636 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
1637 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
1639 /* Punt dynstate expansion and error handling to the C proc. */
1641 scm_fluid_set_x (fluid
, val
);
1644 SCM_SIMPLE_VECTOR_SET (fluids
, num
, val
);
1649 VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals
, "assert-nargs-ee/locals", 1, 0, 0)
1654 /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
1657 if (SCM_UNLIKELY (sp
- (fp
- 1) != (n
& 0x7)))
1658 goto vm_error_wrong_num_args
;
1664 *++old_sp
= SCM_UNDEFINED
;
1671 (defun renumber-ops ()
1672 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1675 (let ((counter -1)) (goto-char (point-min))
1676 (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1678 (number-to-string (setq counter (1+ counter)))