case scm_tc7_hashtable:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
+ case scm_tc7_frame:
+ case scm_tc7_objcode:
+ case scm_tc7_vm:
+ case scm_tc7_vm_cont:
case scm_tc7_number:
case scm_tc7_string:
case scm_tc7_smob:
#include "frames.h"
\f
-scm_t_bits scm_tc16_frame;
-
#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
SCM
p->sp = sp;
p->ip = ip;
p->offset = offset;
- SCM_RETURN_NEWSMOB (scm_tc16_frame, p);
+ return scm_cell (scm_tc7_frame, (scm_t_bits)p);
}
-static int
-frame_print (SCM frame, SCM port, scm_print_state *pstate)
+void
+scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
scm_puts ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
scm_puts (">", port);
-
- return 1;
}
\f
#undef FUNC_NAME
\f
-void
-scm_bootstrap_frames (void)
-{
- scm_tc16_frame = scm_make_smob_type ("frame", 0);
- scm_set_smob_print (scm_tc16_frame, frame_print);
-}
-
void
scm_init_frames (void)
{
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* Heap frames
*/
-SCM_API scm_t_bits scm_tc16_frame;
-
struct scm_frame
{
SCM stack_holder;
scm_t_ptrdiff offset;
};
-#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_frame, x)
-#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_SMOB_DATA (x))
+#define SCM_VM_FRAME_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_frame)
+#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_CELL_WORD_1 (x))
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
SCM_API SCM scm_frame_dynamic_link (SCM frame);
SCM_API SCM scm_frame_previous (SCM frame);
-SCM_INTERNAL void scm_bootstrap_frames (void);
+SCM_INTERNAL void scm_i_frame_print (SCM frame, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */
return "fluid";
case scm_tc7_dynamic_state:
return "dynamic state";
+ case scm_tc7_frame:
+ return "frame";
+ case scm_tc7_objcode:
+ return "objcode";
+ case scm_tc7_vm:
+ return "vm";
+ case scm_tc7_vm_cont:
+ return "vm continuation";
case scm_tc7_wvect:
return "weak vector";
case scm_tc7_vector:
static SCM class_hashtable;
static SCM class_fluid;
static SCM class_dynamic_state;
+static SCM class_frame;
+static SCM class_objcode;
+static SCM class_vm;
+static SCM class_vm_cont;
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
return class_fluid;
case scm_tc7_dynamic_state:
return class_dynamic_state;
+ case scm_tc7_frame:
+ return class_frame;
+ case scm_tc7_objcode:
+ return class_objcode;
+ case scm_tc7_vm:
+ return class_vm;
+ case scm_tc7_vm_cont:
+ return class_vm_cont;
case scm_tc7_string:
return scm_class_string;
case scm_tc7_number:
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_dynamic_state, "<dynamic-state>",
scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_frame, "<frame>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_objcode, "<objcode>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_vm, "<vm>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_vm_cont, "<vm-continuation>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_number, "<number>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_complex, "<complex>",
scm_init_arrays (); /* Requires smob_prehistory, array-handle */
scm_init_array_map ();
- scm_bootstrap_frames (); /* requires smob_prehistory */
scm_bootstrap_instructions ();
- scm_bootstrap_objcodes (); /* requires smob_prehistory */
+ scm_bootstrap_objcodes ();
scm_bootstrap_programs ();
- scm_bootstrap_vm (); /* requires smob_prehistory */
+ scm_bootstrap_vm ();
scm_init_frames (); /* Requires smob_prehistory */
scm_init_stacks (); /* Requires strings, struct, frames */
* Objcode type
*/
-scm_t_bits scm_tc16_objcode;
-
static SCM
make_objcode_by_mmap (int fd)
#define FUNC_NAME "make_objcode_by_mmap"
+ data->metalen)));
}
- SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (SCM_OBJCODE_COOKIE),
- SCM_PACK (SCM_BOOL_F), fd);
- SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
+ sret = scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_MMAP<<8),
+ (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
+ SCM_UNPACK (SCM_BOOL_F),
+ (scm_t_bits)fd);
/* FIXME: we leak ourselves and the file descriptor. but then again so does
dlopen(). */
{
const struct scm_objcode *data, *parent_data;
const scm_t_uint8 *parent_base;
- SCM ret;
SCM_VALIDATE_OBJCODE (1, parent);
parent_data = SCM_OBJCODE_DATA (parent);
assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
<= parent_base + parent_data->len + parent_data->metalen);
- SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
- SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
- return ret;
+ return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_SLICE<<8),
+ (scm_t_bits)data, SCM_UNPACK (parent), 0);
}
#undef FUNC_NAME
size_t size;
const scm_t_uint8 *c_bytecode;
struct scm_objcode *data;
- SCM objcode;
if (!scm_is_bytevector (bytecode))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
scm_list_2 (scm_from_size_t (size),
scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
- SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
- SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_BYTEVECTOR);
-
/* foolishly, we assume that as long as bytecode is around, that c_bytecode
will be of the same length; perhaps a bad assumption? */
-
- return objcode;
+ return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_BYTEVECTOR<<8),
+ (scm_t_bits)data, SCM_UNPACK (bytecode), 0);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
+void
+scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<objcode ", port);
+ scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
+ scm_puts (">", port);
+}
+
\f
void
scm_bootstrap_objcodes (void)
{
- scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
scm_c_register_extension ("libguile", "scm_init_objcodes",
(scm_t_extension_init_func)scm_init_objcodes, NULL);
}
#define SCM_F_OBJCODE_IS_BYTEVECTOR (1<<1)
#define SCM_F_OBJCODE_IS_SLICE (1<<2)
-SCM_API scm_t_bits scm_tc16_objcode;
-
-#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
-#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
+#define SCM_OBJCODE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_objcode)
+#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_CELL_WORD_1 (x))
#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x))
#define SCM_OBJCODE_BASE(x) (SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x)))
-#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
-#define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_BYTEVECTOR)
-#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
+#define SCM_OBJCODE_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 8)
+#define SCM_OBJCODE_IS_MMAP(x) (SCM_OBJCODE_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
+#define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_OBJCODE_FLAGS (x) & SCM_F_OBJCODE_IS_BYTEVECTOR)
+#define SCM_OBJCODE_IS_SLICE(x) (SCM_OBJCODE_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
SCM_API SCM scm_load_objcode (SCM file);
SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
+SCM_INTERNAL void scm_i_objcode_print (SCM objcode, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_objcodes (void);
SCM_INTERNAL void scm_init_objcodes (void);
#include "libguile/vectors.h"
#include "libguile/lang.h"
#include "libguile/numbers.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/print.h"
case scm_tc7_dynamic_state:
scm_i_dynamic_state_print (exp, port, pstate);
break;
+ case scm_tc7_frame:
+ scm_i_frame_print (exp, port, pstate);
+ break;
+ case scm_tc7_objcode:
+ scm_i_objcode_print (exp, port, pstate);
+ break;
+ case scm_tc7_vm:
+ scm_i_vm_print (exp, port, pstate);
+ break;
+ case scm_tc7_vm_cont:
+ scm_i_vm_cont_print (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
#define scm_tc7_fluid 37
#define scm_tc7_dynamic_state 45
-#define scm_tc7_unused_4 47
-#define scm_tc7_unused_5 53
-#define scm_tc7_unused_6 55
-#define scm_tc7_unused_7 71
+#define scm_tc7_frame 47
+#define scm_tc7_objcode 53
+#define scm_tc7_vm 55
+#define scm_tc7_vm_cont 71
#define scm_tc7_unused_17 61
#define scm_tc7_gsubr 63
* VM Continuation
*/
-scm_t_bits scm_tc16_vm_cont;
+void
+scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm-continuation ", port);
+ scm_uintprint (SCM_UNPACK (x), 16, port);
+ scm_puts (">", port);
+}
static SCM
capture_vm_cont (struct scm_vm *vp)
p->fp = vp->fp;
memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
p->reloc = p->stack_base - vp->stack_base;
- SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
+ return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}
static void
SCM_SYMBOL (sym_keyword_argument_error, "keyword-argument-error");
SCM_SYMBOL (sym_debug, "debug");
+void
+scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm ", port);
+ scm_uintprint (SCM_UNPACK (x), 16, port);
+ scm_puts (">", port);
+}
+
static SCM
really_make_boot_program (long nargs)
{
static const scm_t_vm_engine vm_engines[] =
{ vm_regular_engine, vm_debug_engine };
-scm_t_bits scm_tc16_vm;
-
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
/* The GC "kind" for the VM stack. */
int i;
struct scm_vm *vp;
- if (!scm_tc16_vm)
- return SCM_BOOL_F; /* not booted yet */
-
vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
vp->stack_size = VM_DEFAULT_STACK_SIZE;
vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
- SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
+ return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
}
#undef FUNC_NAME
return vm_engines[vp->engine](vm, program, argv, nargs);
}
-SCM
-scm_vm_apply (SCM vm, SCM program, SCM args)
-#define FUNC_NAME "scm_vm_apply"
+SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
+ (SCM vm, SCM program, SCM args),
+ "")
+#define FUNC_NAME s_scm_vm_apply
{
SCM *argv;
int i, nargs;
void
scm_bootstrap_vm (void)
{
- scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
-
- scm_tc16_vm = scm_make_smob_type ("vm", 0);
- scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
-
scm_c_register_extension ("libguile", "scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
SCM_API SCM scm_the_vm_fluid;
-#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
-#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
+#define SCM_VM_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_vm)
+#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_CELL_WORD_1 (vm))
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
SCM_API SCM scm_the_vm ();
scm_t_ptrdiff reloc;
};
-SCM_API scm_t_bits scm_tc16_vm_cont;
-#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_SMOB_DATA_1 (CONT))
+#define SCM_VM_CONT_P(OBJ) (SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) == scm_tc7_vm_cont)
+#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
SCM_API SCM scm_vm_capture_continuations (void);
SCM_API void scm_vm_reinstate_continuations (SCM conts);
SCM_API SCM scm_load_compiled_with_vm (SCM file);
+SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
+ scm_print_state *pstate);
+SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_vm (void);
SCM_INTERNAL void scm_init_vm (void);
;;; Repl commands
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; FIXME opts
(let ((vm (repl-vm repl))
(proc (make-program (repl-compile repl (repl-parse repl form)))))
- (with-statprof #:hz 100 (vm proc))))
+ (with-statprof #:hz 100 (vm-apply vm proc '()))))
\f
;;; Guile VM tracer
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
(define (vm-trace vm thunk . opts)
(dynamic-wind
(lambda () (apply vm-trace-on! vm opts))
- (lambda () (vm thunk))
+ (lambda () (vm-apply vm thunk '()))
(lambda () (apply vm-trace-off! vm opts))))
(define* (vm-trace-on! vm #:key (calls? #t) (instructions? #f))
;;; Guile VM core
-;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
(define-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:export (vm? the-vm make-vm vm-version
+ #:export (vm? the-vm make-vm vm-version vm-apply
vm:ip vm:sp vm:fp vm:last-ip
vm-load vm-option set-vm-option! vm-version
(define (vms:clock stat) (vector-ref stat 1))
(define (vm-load vm objcode)
- (vm (make-program objcode)))
+ (vm-apply vm (make-program objcode) '()))
HCoop / bpt / guile.git / commitdiff