diff --git a/libguile/evalext.c b/libguile/evalext.c index 32f1f4f4c..5b86a918d 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -81,6 +81,10 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, 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: diff --git a/libguile/frames.c b/libguile/frames.c index 29c14c8f1..f8eed861a 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -26,8 +26,6 @@ #include "frames.h" -scm_t_bits scm_tc16_frame; - #define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame)) SCM @@ -41,11 +39,11 @@ scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp, 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 ("#", port); - - return 1; } @@ -291,13 +287,6 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, #undef FUNC_NAME -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) { diff --git a/libguile/frames.h b/libguile/frames.h index 0636fe8a1..33432eb48 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,4 +1,4 @@ -/* 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 @@ -87,8 +87,6 @@ * Heap frames */ -SCM_API scm_t_bits scm_tc16_frame; - struct scm_frame { SCM stack_holder; @@ -98,8 +96,8 @@ struct scm_frame 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 @@ -122,7 +120,8 @@ SCM_API SCM scm_frame_mv_return_address (SCM frame); 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_ */ diff --git a/libguile/gc.c b/libguile/gc.c index d5943b42a..4c898bcba 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -756,6 +756,14 @@ scm_i_tag_name (scm_t_bits tag) 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: diff --git a/libguile/goops.c b/libguile/goops.c index a703e7a7e..ca850fa8c 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -162,6 +162,10 @@ static SCM class_foreign; 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 @@ -223,6 +227,14 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, 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: @@ -2402,6 +2414,14 @@ create_standard_classes (void) scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_dynamic_state, "", scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&class_frame, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&class_objcode, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&class_vm, "", + scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&class_vm_cont, "", + scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_number, "", scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_complex, "", diff --git a/libguile/init.c b/libguile/init.c index e2e90a1d7..b3d67a9b9 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -522,11 +522,10 @@ scm_i_init_guile (SCM_STACKITEM *base) 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 */ diff --git a/libguile/objcodes.c b/libguile/objcodes.c index cd5506f53..f30d815af 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -42,8 +42,6 @@ verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0); * Objcode type */ -scm_t_bits scm_tc16_objcode; - static SCM make_objcode_by_mmap (int fd) #define FUNC_NAME "make_objcode_by_mmap" @@ -90,9 +88,10 @@ make_objcode_by_mmap (int fd) + 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(). */ @@ -106,7 +105,6 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) { 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); @@ -130,9 +128,8 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) 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 @@ -173,7 +170,6 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0, 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); @@ -189,13 +185,10 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0, 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 @@ -253,11 +246,18 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0, } #undef FUNC_NAME +void +scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate) +{ + scm_puts ("#", port); +} + 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); } diff --git a/libguile/objcodes.h b/libguile/objcodes.h index f28f713e0..498c606ba 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -39,10 +39,8 @@ struct scm_objcode #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) @@ -50,9 +48,10 @@ SCM_API scm_t_bits scm_tc16_objcode; #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); @@ -62,6 +61,8 @@ SCM_API SCM scm_bytecode_to_objcode (SCM bytecode); 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); diff --git a/libguile/print.c b/libguile/print.c index 6e3d1f444..715037b67 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -45,6 +45,7 @@ #include "libguile/vectors.h" #include "libguile/lang.h" #include "libguile/numbers.h" +#include "libguile/vm.h" #include "libguile/validate.h" #include "libguile/print.h" @@ -720,6 +721,18 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) 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)) diff --git a/libguile/tags.h b/libguile/tags.h index a8ecf0f4f..64a870eac 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -416,10 +416,10 @@ typedef scm_t_uintptr scm_t_bits; #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 diff --git a/libguile/vm.c b/libguile/vm.c index 5d0c4c9bc..07cdbc088 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -71,7 +71,13 @@ * 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 ("#", port); +} static SCM capture_vm_cont (struct scm_vm *vp) @@ -91,7 +97,7 @@ 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 @@ -173,6 +179,14 @@ SCM_SYMBOL (sym_vm_error, "vm-error"); 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 ("#", port); +} + static SCM really_make_boot_program (long nargs) { @@ -315,8 +329,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom) 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. */ @@ -331,9 +343,6 @@ make_vm (void) 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; @@ -364,7 +373,7 @@ make_vm (void) 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 @@ -407,9 +416,10 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs) 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; @@ -653,11 +663,6 @@ SCM scm_load_compiled_with_vm (SCM file) 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); diff --git a/libguile/vm.h b/libguile/vm.h index 8ae09faae..c121061f3 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -55,8 +55,8 @@ struct scm_vm { 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 (); @@ -95,15 +95,18 @@ struct scm_vm_cont { 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); diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 5fac6f6f3..721d2b3a5 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -367,7 +367,7 @@ Profile execution." ;; 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 '())))) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index c260ab488..330b50f68 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -28,7 +28,7 @@ (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)) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm index 76bdb57d7..c6e550b05 100644 --- a/module/system/vm/vm.scm +++ b/module/system/vm/vm.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -21,7 +21,7 @@ (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 @@ -37,4 +37,4 @@ (define (vms:clock stat) (vector-ref stat 1)) (define (vm-load vm objcode) - (vm (make-program objcode))) + (vm-apply vm (make-program objcode) '()))