mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-07 09:39:38 +00:00
parent 4bfb26f58f
commit 3616e9e963
17 changed files with 248 additions and 205 deletions
Download patch file Download diff file Expand all files Collapse all files

2
module/system/base/language.scm
View file

@ -99,7 +99,7 @@
(let ((compiled (object-file-name file)))
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(compile-file-in file env lang))
(compile-file-in file env lang :O))
(call-with-input-file compiled
(lambda (p)
(let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))

38
module/system/il/compile.scm
View file

@ -39,14 +39,36 @@
(define (optimize x)
(match x
(($ <ghil-call> proc args)
(($ <ghil-set> env var val)
(make-<ghil-set> env var (optimize val)))
(($ <ghil-if> test then else)
(make-<ghil-if> (optimize test) (optimize then) (optimize else)))
(($ <ghil-begin> exps)
(make-<ghil-begin> (map optimize exps)))
(($ <ghil-bind> env vars vals body)
(make-<ghil-bind> env vars (map optimize vals) (optimize body)))
(($ <ghil-lambda> env vars rest body)
(make-<ghil-lambda> env vars rest (optimize body)))
(($ <ghil-inst> inst args)
(make-<ghil-inst> inst (map optimize args)))
(($ <ghil-call> env proc args)
(match proc
;; ((@lambda (VAR...) BODY...) ARG...) =>
;; (@let ((VAR ARG) ...) BODY...)
(($ <ghil-lambda> env vars #f body)
(optimize (make-<ghil-bind> vars args body)))
(($ <ghil-lambda> lambda-env vars #f body)
(for-each (lambda (v)
(if (eq? v.kind 'argument) (set! v.kind 'local))
(ghil-env-add! env v))
lambda-env.variables)
(optimize (make-<ghil-bind> env vars args body)))
(else
(make-<ghil-call> (optimize proc) (for-each optimize args)))))
(make-<ghil-call> env (optimize proc) (map optimize args)))))
(else x)))
@ -144,7 +166,7 @@
(reverse vars))
(comp-tail body))
(($ <ghil-lambda> vars rest body)
(($ <ghil-lambda> env vars rest body)
(return-code! (codegen tree)))
(($ <ghil-inst> inst args)
@ -155,12 +177,12 @@
(if drop (push-code! *ia-drop*))
(if tail (push-code! *ia-return*)))
(($ <ghil-call> proc args)
;; ARGS...
(($ <ghil-call> env proc args)
;; PROC
;; ARGS...
;; ([tail-]call NARGS)
(for-each comp-push args)
(comp-push proc)
(for-each comp-push args)
(let ((inst (if tail 'tail-call 'call)))
(push-code! (make-<glil-call> inst (length args))))
(if drop (push-code! *ia-drop*)))))

45
module/system/il/ghil.scm
View file

@ -37,7 +37,7 @@
<ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4
make-<ghil-lambda> <ghil-lambda>?
<ghil-lambda>-1 <ghil-lambda>-2 <ghil-lambda>-3 <ghil-lambda>-4
make-<ghil-call> <ghil-call>? <ghil-call>-1 <ghil-call>-2
make-<ghil-call> <ghil-call>? <ghil-call>-1 <ghil-call>-2 <ghil-call>-3
make-<ghil-inst> <ghil-inst>? <ghil-inst>-1 <ghil-inst>-2
))
@ -53,8 +53,8 @@
(define-structure (<ghil-if> test then else))
(define-structure (<ghil-begin> exps))
(define-structure (<ghil-bind> env vars vals body))
(define-structure (<ghil-lambda> env args rest body))
(define-structure (<ghil-call> proc args))
(define-structure (<ghil-lambda> env vars rest body))
(define-structure (<ghil-call> env proc args))
(define-structure (<ghil-inst> inst args))
@ -128,14 +128,13 @@
(define-method (ghil-env-ref (env <ghil-env>) (sym <symbol>))
(assq-ref env.table sym))
(define-method (ghil-env-add! (env <ghil-env>) (sym <symbol>) kind)
(let ((var (make-ghil-var env sym kind)))
(set! env.table (acons sym var env.table))
(set! env.variables (cons var env.variables))
var))
(export ghil-env-add!)
(define-method (ghil-env-add! (env <ghil-env>) (var <ghil-var>))
(set! env.table (acons var.name var env.table))
(set! env.variables (cons var env.variables)))
(define-method (ghil-env-remove! (env <ghil-env>) (sym <symbol>))
(set! env.table (assq-remove! env.table sym)))
(define-method (ghil-env-remove! (env <ghil-env>) (var <ghil-var>))
(set! env.table (assq-remove! env.table var.name)))
(define-method (ghil-lookup (env <ghil-env>) (sym <symbol>))
(or (ghil-env-ref env sym)
@ -173,7 +172,7 @@
(if (ghil-primitive-macro? head)
(parse (apply (ghil-macro-expander head) tail) e)
(parse-primitive head tail e))
(make-<ghil-call> (parse head e) (map-parse tail e)))))
(make-<ghil-call> e (parse head e) (map-parse tail e)))))
(define (parse-primitive prim args e)
(case prim
@ -229,24 +228,17 @@
((@begin)
(parse-body args e))
;; (@let ((SYM INIT)...) BODY...)
((@let)
(match args
((((sym init) ...) body ...)
(let* ((vals (map-parse init e))
(vars (map (lambda (s) (ghil-env-add! e s 'local)) sym))
(body (parse-body body e)))
(for-each (lambda (s) (ghil-env-remove! e s)) sym)
(make-<ghil-bind> e vars vals body)))))
;; (@letrec ((SYM INIT)...) BODY...)
((@letrec)
(match args
((((sym init) ...) body ...)
(let* ((vars (map (lambda (s) (ghil-env-add! e s 'local)) sym))
(let* ((vars (map (lambda (s)
(let ((v (make-ghil-var e s 'local)))
(ghil-env-add! e v) v))
sym))
(vals (map-parse init e))
(body (parse-body body e)))
(for-each (lambda (s) (ghil-env-remove! e s)) sym)
(for-each (lambda (v) (ghil-env-remove! e v)) vars)
(make-<ghil-bind> e vars vals body)))))
;; (@lambda FORMALS BODY...)
@ -255,8 +247,11 @@
((formals . body)
(receive (syms rest) (parse-formals formals)
(let* ((e (make-ghil-env e))
(args (map (lambda (s) (ghil-env-add! e s 'argument)) syms)))
(make-<ghil-lambda> e args rest (parse-body body e)))))))
(vars (map (lambda (s)
(let ((v (make-ghil-var e s 'argument)))
(ghil-env-add! e v) v))
syms)))
(make-<ghil-lambda> e vars rest (parse-body body e)))))))
(else (error "Unknown primitive:" prim))))

4
module/system/il/macros.scm
View file

@ -260,9 +260,9 @@
;;;; 6.4 Control features
;; (define (@procedure? x) `(@@ procedure? x))
(define (@procedure? x) `((@ Core::procedure?) ,x))
;; (define (@apply proc . args) ...)
(define (@apply proc . args) `(@@ apply ,proc ,@args))
;;; (define (@force promise) `(@@ force promise))

2
module/system/repl/command.scm
View file

@ -353,7 +353,7 @@ Start debugger."
(debug))
(define (trace repl form . opts)
"trace [-a] FORM
"trace [-b] FORM
Trace execution."
(apply vm-trace repl.vm (repl-compile repl form) opts))

12
module/system/vm/assemble.scm
View file

@ -72,8 +72,7 @@
(($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
(let ((stack '())
(label-alist '())
(object-alist '())
(nvars (+ nargs nlocs -1)))
(object-alist '()))
(define (push-code! code)
(set! stack (optimizing-push code stack)))
(define (push-object! x)
@ -106,18 +105,17 @@
(else (push-object! x)))))
(($ <glil-argument> op index)
(push-code! `(,(symbol-append 'local- op) ,(- nvars index))))
(push-code! `(,(symbol-append 'local- op) ,index)))
(($ <glil-local> op index)
(push-code! `(,(symbol-append 'local- op)
,(- nvars (+ nargs index)))))
(push-code! `(,(symbol-append 'local- op) ,(+ nargs index))))
(($ <glil-external> op depth index)
(do ((e venv (venv-parent e))
(d depth (1- d))
(i 0 (+ i (venv-nexts e))))
(n 0 (+ n (venv-nexts e))))
((= d 0)
(push-code! `(,(symbol-append 'external- op) ,(+ index i))))))
(push-code! `(,(symbol-append 'external- op) ,(+ n index))))))
(($ <glil-module> op module name)
;; (let ((vlink (make-vlink (make-vmod module) name)))

2
module/system/vm/disasm.scm
View file

@ -47,7 +47,7 @@
(objs (program-objects prog)))
;; Disassemble this bytecode
(format #t "Disassembly of ~A:\n\n" prog)
(format #t "nargs = ~A nrest = ~A nlocs = ~A nexts ~A\n\n"
(format #t "nargs = ~A nrest = ~A nlocs = ~A nexts = ~A\n\n"
nargs nrest nlocs nexts)
(format #t "Bytecode:\n\n")
(disassemble-bytecode bytes objs)

2
module/system/vm/load.scm
View file

@ -30,7 +30,7 @@
(compiled (object-file-name file)))
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(compile-file-in file #f (lookup-language 'gscheme)))
(compile-file-in file #f (lookup-language 'gscheme) :O))
(let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
(call-with-input-file compiled
(lambda (p) (uniform-vector-read! bytes p)))

4
module/system/vm/trace.scm
View file

@ -30,14 +30,14 @@
(dynamic-wind
(lambda ()
(set-vm-option! vm 'trace-first #t)
(if (memq :a opts)
(if (memq :b opts)
(add-hook! (vm-next-hook vm) trace-next))
(add-hook! (vm-apply-hook vm) trace-apply)
(add-hook! (vm-return-hook vm) trace-return))
(lambda ()
(vm-load vm bytes))
(lambda ()
(if (memq :a opts)
(if (memq :b opts)
(remove-hook! (vm-next-hook vm) trace-next))
(remove-hook! (vm-apply-hook vm) trace-apply)
(remove-hook! (vm-return-hook vm) trace-return))))

117
src/vm.c
View file

@ -54,39 +54,30 @@
/*
* VM Debug frame
* VM Heap frame
*/
scm_bits_t scm_tc16_vm_debug_frame;
scm_bits_t scm_tc16_vm_heap_frame;
static SCM
make_vm_debug_frame (SCM *fp)
make_vm_heap_frame (SCM *fp)
{
int i, size;
struct scm_vm_debug_frame *p;
if (!fp)
return SCM_BOOL_F;
p = scm_must_malloc (sizeof (struct scm_vm_debug_frame), "make_vm_debug_frame");
p->program = SCM_VM_FRAME_PROGRAM (fp);
p->dynamic_link = make_vm_debug_frame (SCM_VM_FRAME_ADDRESS
(SCM_VM_FRAME_DYNAMIC_LINK (fp)));
size = SCM_PROGRAM_NARGS (p->program) + SCM_PROGRAM_NLOCS (p->program);
p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
for (i = 0; i < size; i++)
SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i);
SCM_RETURN_NEWSMOB (scm_tc16_vm_debug_frame, p);
struct scm_vm_heap_frame *p =
scm_must_malloc (sizeof (struct scm_vm_heap_frame), "make_vm_heap_frame");
p->fp = fp;
p->program = SCM_UNDEFINED;
p->variables = SCM_UNDEFINED;
p->dynamic_link = SCM_UNDEFINED;
SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_frame, p);
}
static SCM
vm_debug_frame_mark (SCM obj)
vm_heap_frame_mark (SCM obj)
{
scm_gc_mark (SCM_VM_DEBUG_FRAME_PROGRAM (obj));
scm_gc_mark (SCM_VM_DEBUG_FRAME_VARIABLES (obj));
return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (obj);
struct scm_vm_heap_frame *p = SCM_VM_HEAP_FRAME_DATA (obj);
scm_gc_mark (p->program);
scm_gc_mark (p->variables);
return p->dynamic_link;
}
/* Scheme interface */
@ -96,7 +87,7 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_p
{
return SCM_BOOL (SCM_VM_DEBUG_FRAME_P (obj));
return SCM_BOOL (SCM_VM_HEAP_FRAME_P (obj));
}
#undef FUNC_NAME
@ -105,8 +96,8 @@ SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_program
{
SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
return SCM_VM_DEBUG_FRAME_PROGRAM (frame);
SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
return SCM_VM_FRAME_PROGRAM (SCM_VM_HEAP_FRAME_DATA (frame)->fp);
}
#undef FUNC_NAME
@ -115,8 +106,20 @@ SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_variables
{
SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
return SCM_VM_DEBUG_FRAME_VARIABLES (frame);
struct scm_vm_heap_frame *p;
SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
p = SCM_VM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->variables))
{
SCM prog = scm_frame_program (frame);
int i, size = SCM_PROGRAM_NARGS (prog) + SCM_PROGRAM_NLOCS (prog);
p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
for (i = 0; i < size; i++)
SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (p->fp, i);
}
return p->variables;
}
#undef FUNC_NAME
@ -125,8 +128,21 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_dynamic_link
{
SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (frame);
struct scm_vm_heap_frame *p;
SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
p = SCM_VM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->dynamic_link))
{
SCM *fp = SCM_VM_STACK_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (p->fp));
if (fp)
p->dynamic_link = make_vm_heap_frame (fp);
else
p->dynamic_link = SCM_BOOL_F;
}
return p->dynamic_link;
}
#undef FUNC_NAME
@ -260,10 +276,10 @@ make_vm (void)
struct scm_vm *vp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
vp->stack_size = VM_DEFAULT_STACK_SIZE;
vp->stack_base = SCM_MUST_MALLOC (vp->stack_size * sizeof (SCM));
vp->stack_limit = vp->stack_base + vp->stack_size;
vp->ip = NULL;
vp->sp = vp->stack_limit;
vp->fp = NULL;
vp->stack_limit = vp->stack_base + vp->stack_size - 3;
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->fp = NULL;
vp->time = 0;
vp->clock = 0;
vp->options = SCM_EOL;
@ -288,16 +304,14 @@ vm_mark (SCM obj)
SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp);
SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp);
/* Mark intermediate data */
for (; sp < lower; sp++)
for (; sp >= upper; sp--)
if (SCM_NIMP (*sp))
scm_gc_mark (*sp);
/* Mark frame data */
scm_gc_mark (SCM_VM_FRAME_PROGRAM (fp));
/* Mark frame variables */
for (sp = fp; sp < upper; sp++)
fp = SCM_VM_STACK_ADDRESS (*sp); /* dynamic link */
/* Mark frame variables + program */
for (sp -= 2; sp >= lower; sp--)
if (SCM_NIMP (*sp))
scm_gc_mark (*sp);
fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp));
}
/* Mark the options */
@ -519,7 +533,7 @@ SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
{
SCM_VALIDATE_VM (1, vm);
VM_CHECK_RUNNING (vm);
return make_vm_debug_frame (SCM_VM_DATA (vm)->fp);
return make_vm_heap_frame (SCM_VM_DATA (vm)->fp);
}
#undef FUNC_NAME
@ -551,18 +565,17 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
"")
#define FUNC_NAME s_scm_vm_fetch_stack
{
SCM *p;
SCM list = SCM_EOL;
SCM *sp;
SCM ls = SCM_EOL;
struct scm_vm *vp;
SCM_VALIDATE_VM (1, vm);
VM_CHECK_RUNNING (vm);
if (SCM_VM_DATA (vm)->fp)
for (p = SCM_VM_FRAME_LOWER_ADDRESS (SCM_VM_DATA (vm)->fp) - 1;
p >= SCM_VM_DATA (vm)->sp;
p--)
list = scm_cons (*p, list);
return list;
vp = SCM_VM_DATA (vm);
for (sp = SCM_VM_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++)
ls = scm_cons (*sp, ls);
return ls;
}
#undef FUNC_NAME
@ -606,8 +619,8 @@ scm_init_vm (void)
scm_init_instructions ();
scm_init_programs ();
scm_tc16_vm_debug_frame = scm_make_smob_type ("vm_frame", 0);
scm_set_smob_mark (scm_tc16_vm_debug_frame, vm_debug_frame_mark);
scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0);
scm_set_smob_mark (scm_tc16_vm_heap_frame, vm_heap_frame_mark);
scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);

58
src/vm.h
View file

@ -50,62 +50,62 @@
* VM Address
*/
#define SCM_VM_MAKE_FRAME_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_FRAME_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr))
#define SCM_VM_MAKE_STACK_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_STACK_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr))
#define SCM_VM_MAKE_BYTE_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_BYTE_ADDRESS(addr) ((scm_byte_t *) SCM_UNPACK (addr))
/*
* VM Frame
* VM Stack frame
*/
/*
| | <- fp + bp->nlocs + bp->nargs
| | <- fp + bp->nargs + bp->nlocs + 2
+------------------+ = SCM_VM_FRAME_UPPER_ADDRESS (fp)
| Argument 1 |
| Argument 2 | <- fp + bp->nlocs
| Local variable 1 |
| Local varialbe 2 | <- fp
| Program |
| Dynamic link |
| Return address | <- fp - SCM_VM_FRAME_DATA_SIZE
| Return address | <- fp + bp->nargs + bp->nlocs
| Local varialbe 1 | = SCM_VM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
+------------------+ = SCM_VM_FRAME_LOWER_ADDRESS (fp)
| |
*/
/* Frames are allocated on the stack */
#define SCM_VM_FRAME_DATA_SIZE 3
#define SCM_VM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_VM_FRAME_PROGRAM(fp) fp[-1]
#define SCM_VM_FRAME_DYNAMIC_LINK(fp) fp[-2]
#define SCM_VM_FRAME_RETURN_ADDRESS(fp) fp[-3]
#define SCM_VM_FRAME_UPPER_ADDRESS(fp) \
#define SCM_VM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_VM_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_NARGS (SCM_VM_FRAME_PROGRAM (fp)) \
+ SCM_PROGRAM_NLOCS (SCM_VM_FRAME_PROGRAM (fp)))
#define SCM_VM_FRAME_LOWER_ADDRESS(fp) \
(fp - SCM_VM_FRAME_DATA_SIZE)
#define SCM_VM_FRAME_UPPER_ADDRESS(fp) \
(SCM_VM_FRAME_DATA_ADDRESS (fp) + 2)
#define SCM_VM_FRAME_DYNAMIC_LINK(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[1]
#define SCM_VM_FRAME_RETURN_ADDRESS(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[2]
#define SCM_VM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_VM_FRAME_PROGRAM(fp) fp[-1]
/*
* VM Debug frame
* VM Heap frame
*/
struct scm_vm_debug_frame {
struct scm_vm_heap_frame {
SCM *fp;
SCM program;
SCM variables;
SCM dynamic_link;
};
extern scm_bits_t scm_tc16_vm_debug_frame;
extern scm_bits_t scm_tc16_vm_heap_frame;
#define SCM_VM_DEBUG_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_debug_frame, x)
#define SCM_VM_DEBUG_FRAME_DATA(f) ((struct scm_vm_debug_frame *) SCM_SMOB_DATA (f))
#define SCM_VALIDATE_VM_DEBUG_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_DEBUG_FRAME_P)
#define SCM_VM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_heap_frame, x)
#define SCM_VM_HEAP_FRAME_DATA(f) ((struct scm_vm_heap_frame *) SCM_SMOB_DATA (f))
#define SCM_VALIDATE_VM_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_HEAP_FRAME_P)
#define SCM_VM_DEBUG_FRAME_PROGRAM(f) SCM_VM_DEBUG_FRAME_DATA (f)->program
#define SCM_VM_DEBUG_FRAME_VARIABLES(f) SCM_VM_DEBUG_FRAME_DATA (f)->variables
#define SCM_VM_DEBUG_FRAME_DYNAMIC_LINK(f) SCM_VM_DEBUG_FRAME_DATA (f)->dynamic_link
#define SCM_VM_HEAP_FRAME_PROGRAM(f) SCM_VM_HEAP_FRAME_DATA (f)->program
#define SCM_VM_HEAP_FRAME_VARIABLES(f) SCM_VM_HEAP_FRAME_DATA (f)->variables
#define SCM_VM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->dynamic_link
/*
* VM

3
src/vm_engine.c
View file

@ -94,12 +94,13 @@ vm_engine (SCM vm, SCM program, SCM args)
/* Initial frame */
CACHE_REGISTER ();
CACHE_PROGRAM ();
PUSH (program);
NEW_FRAME ();
/* Initial arguments */
PUSH (prog);
for (; !SCM_NULLP (args); args = SCM_CDR (args))
PUSH (SCM_CAR (args));
PUSH (prog);
}
/* Let's go! */

59
src/vm_engine.h
View file

@ -179,15 +179,15 @@
*/
#define CHECK_OVERFLOW() \
if (sp < stack_base) \
if (sp > stack_limit) \
goto vm_error_stack_overflow
#define CHECK_UNDERFLOW() \
if (sp >= stack_limit) \
if (sp < stack_base) \
goto vm_error_stack_underflow
#define PUSH(x) do { CHECK_OVERFLOW (); *--sp = x; } while (0)
#define DROP() do { CHECK_UNDERFLOW (); sp++; } while (0)
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
#define DROP() do { CHECK_UNDERFLOW (); sp--; } while (0)
#define POP(x) do { x = *sp; DROP (); } while (0)
#define CONS(x,y,z) \
@ -204,10 +204,10 @@
do { \
int i; \
SCM l = SCM_EOL; \
for (i = 0; i < n; i++) \
sp -= n; \
for (i = n; i; i--) \
CONS (l, sp[i], l); \
sp += n - 1; \
*sp = l; \
PUSH (l); \
} while (0)
@ -245,8 +245,8 @@ do { \
*/
#define ARGS1(a1) SCM a1 = sp[0];
#define ARGS2(a1,a2) SCM a1 = sp[1], a2 = sp[0]; sp++;
#define ARGS3(a1,a2,a3) SCM a1 = sp[2], a2 = sp[1], a3 = sp[0]; sp += 2;
#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--;
#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2;
#define ARGSN(an) int an = FETCH ();
#define RETURN(x) do { *sp = x; NEXT; } while (0)
@ -256,26 +256,6 @@ do { \
* Frame allocation
*/
#define NEW_FRAME() \
{ \
SCM ra = SCM_VM_MAKE_FRAME_ADDRESS (ip); \
SCM dl = SCM_VM_MAKE_BYTE_ADDRESS (fp); \
ip = bp->base; \
fp = sp - bp->nlocs; \
sp = SCM_VM_FRAME_LOWER_ADDRESS (fp); \
CHECK_OVERFLOW (); \
SCM_VM_FRAME_PROGRAM (fp) = program; \
SCM_VM_FRAME_DYNAMIC_LINK (fp) = dl; \
SCM_VM_FRAME_RETURN_ADDRESS (fp) = ra; \
}
#define FREE_FRAME() \
{ \
sp = fp + bp->nargs + bp->nlocs; \
ip = SCM_VM_BYTE_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (fp)); \
fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp)); \
}
#define INIT_ARGS() \
{ \
if (bp->nrest) \
@ -292,6 +272,27 @@ do { \
} \
}
/* See vm.h for the layout of stack frames */
#define NEW_FRAME() \
{ \
sp[1] = SCM_VM_MAKE_BYTE_ADDRESS (ip); \
sp[2] = SCM_VM_MAKE_STACK_ADDRESS (fp); \
ip = bp->base; \
fp = sp - bp->nargs + 1; \
sp = sp + 2; \
CHECK_OVERFLOW (); \
}
#define FREE_FRAME() \
{ \
SCM *new_sp = fp - 2; \
sp = fp + bp->nargs + bp->nlocs; \
ip = SCM_VM_BYTE_ADDRESS (sp[0]); \
fp = SCM_VM_STACK_ADDRESS (sp[1]); \
sp = new_sp; \
}
/*
Local Variables:
c-file-style: "gnu"

6
src/vm_expand.h
View file

@ -56,6 +56,7 @@
#undef VM_DEFINE_INSTRUCTION
#undef VM_DEFINE_FUNCTION
#undef VM_DEFINE_LOADER
#ifdef VM_INSTRUCTION_TO_TABLE
/*
* These will go to scm_instruction_table in vm.c
@ -64,6 +65,8 @@
{VM_OPCODE (tag), name, len, npop, npush},
#define VM_DEFINE_FUNCTION(tag,name,nargs) \
{VM_OPCODE (tag), name, (nargs < 0) ? 1 : 0, nargs, 1},
#define VM_DEFINE_LOADER(tag,name) \
{VM_OPCODE (tag), name, -1, 0, 1},
#else
#ifdef VM_INSTRUCTION_TO_LABEL
@ -72,6 +75,7 @@
*/
#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_ADDR (tag),
#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag),
#define VM_DEFINE_LOADER(tag,name) VM_ADDR (tag),
#else
#ifdef VM_INSTRUCTION_TO_OPCODE
@ -80,6 +84,7 @@
*/
#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_OPCODE (tag),
#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag),
#define VM_DEFINE_LOADER(tag,name) VM_OPCODE (tag),
#else /* Otherwise */
/*
@ -87,6 +92,7 @@
*/
#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_TAG (tag)
#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag)
#define VM_DEFINE_LOADER(tag,name) VM_TAG (tag)
#endif /* VM_INSTRUCTION_TO_OPCODE */
#endif /* VM_INSTRUCTION_TO_LABEL */

28
src/vm_loader.c
View file

@ -41,7 +41,7 @@
/* This file is included in vm_engine.c */
VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1, 0, 1)
VM_DEFINE_LOADER (load_integer, "load-integer")
{
size_t len;
@ -58,7 +58,7 @@ VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1, 0, 1)
SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
}
VM_DEFINE_INSTRUCTION (load_number, "load-number", -1, 0, 1)
VM_DEFINE_LOADER (load_number, "load-number")
{
size_t len;
FETCH_LENGTH (len);
@ -67,7 +67,7 @@ VM_DEFINE_INSTRUCTION (load_number, "load-number", -1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (load_string, "load-string", -1, 0, 1)
VM_DEFINE_LOADER (load_string, "load-string")
{
size_t len;
FETCH_LENGTH (len);
@ -76,7 +76,7 @@ VM_DEFINE_INSTRUCTION (load_string, "load-string", -1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1, 0, 1)
VM_DEFINE_LOADER (load_symbol, "load-symbol")
{
size_t len;
FETCH_LENGTH (len);
@ -85,7 +85,7 @@ VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1, 0, 1)
VM_DEFINE_LOADER (load_keyword, "load-keyword")
{
SCM sym;
size_t len;
@ -96,7 +96,7 @@ VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (load_module, "load-module", -1, 0, 1)
VM_DEFINE_LOADER (load_module, "load-module")
{
size_t len;
FETCH_LENGTH (len);
@ -105,7 +105,7 @@ VM_DEFINE_INSTRUCTION (load_module, "load-module", -1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
VM_DEFINE_LOADER (load_program, "load-program")
{
size_t len;
SCM prog, x;
@ -148,11 +148,11 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
else
{
/* Other cases */
SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[4]);
SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[3]);
SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[2]);
SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[1]);
sp += 4;
sp -= 4;
SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[1]);
SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]);
SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[3]);
SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[4]);
}
*sp = prog;
@ -161,8 +161,8 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
{
sp[1] = scm_c_env_vcell (sp[1], sp[0], 1);
DROP ();
sp--;
*sp = scm_c_env_vcell (sp[0], sp[1], 1);
NEXT;
}

3
src/vm_scheme.c
View file

@ -169,8 +169,7 @@ VM_DEFINE_FUNCTION (vector, "vector", -1)
{
ARGSN (n);
POP_LIST (n);
*sp = scm_vector (*sp);
NEXT;
RETURN (scm_vector (*sp));
}

68
src/vm_system.c
View file

@ -209,9 +209,9 @@ VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[1]);
scm_set_object_property_x (sp[1], scm_sym_name, SCM_CAR (sp[0]));
sp += 2;
VARIABLE_SET (sp[0], sp[-1]);
scm_set_object_property_x (sp[-1], scm_sym_name, SCM_CAR (sp[0]));
sp -= 2;
NEXT;
}
@ -279,23 +279,27 @@ VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
{
POP (program);
SCM x;
nargs = FETCH ();
x = sp[-nargs];
vm_call:
/*
* Subprogram call
*/
if (SCM_PROGRAM_P (program))
if (SCM_PROGRAM_P (x))
{
int i;
int i, last;
program = x;
vm_call_program:
CACHE_PROGRAM ();
INIT_ARGS ();
NEW_FRAME ();
/* Init local variables */
for (i = 0; i < bp->nlocs; i++)
last = bp->nargs + bp->nlocs;
for (i = bp->nargs; i < last; i++)
LOCAL_SET (i, SCM_UNDEFINED);
/* Create external variables */
@ -309,29 +313,29 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
/*
* Function call
*/
if (!SCM_FALSEP (scm_procedure_p (program)))
if (!SCM_FALSEP (scm_procedure_p (x)))
{
POP_LIST (nargs);
*sp = scm_apply (program, *sp, SCM_EOL);
program = SCM_VM_FRAME_PROGRAM (fp);
sp[-1] = scm_apply (x, *sp, SCM_EOL);
sp--;
NEXT;
}
/*
* Continuation call
*/
if (SCM_VM_CONT_P (program))
if (SCM_VM_CONT_P (x))
{
vm_call_cc:
/* Check the number of arguments */
if (nargs != 1)
scm_wrong_num_args (program);
scm_wrong_num_args (x);
/* Reinstate the continuation */
EXIT_HOOK ();
reinstate_vm_cont (vp, program);
reinstate_vm_cont (vp, x);
CACHE_REGISTER ();
/* We don't need to set the return value here
because it is already on the top of the stack. */
program = SCM_VM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
NEXT;
}
@ -341,8 +345,8 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
{
SCM x;
POP (x);
nargs = FETCH ();
x = sp[-nargs];
SCM_TICK; /* allow interrupt here */
@ -357,56 +361,60 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
if (bp->nargs)
{
int i;
SCM *base = fp + bp->nlocs;
sp -= bp->nargs - 1;
for (i = 0; i < bp->nargs; i++)
base[i] = sp[i];
LOCAL_SET (i, sp[i]);
sp -= 2;
}
ip = bp->base;
sp = SCM_VM_FRAME_LOWER_ADDRESS (fp);
APPLY_HOOK ();
NEXT;
}
program = x;
/*
* Proper tail call
*/
if (SCM_PROGRAM_P (program))
if (SCM_PROGRAM_P (x))
{
int i;
SCM *base = sp;
SCM *limit = sp;
SCM *base = sp - nargs - 1;
/* Exit the current frame */
EXIT_HOOK ();
FREE_FRAME ();
/* Move arguments */
sp -= nargs;
for (i = 0; i < nargs; i++)
sp[i] = base[i];
while (base < limit)
*++sp = *++base;
/* Call the program */
program = x;
goto vm_call_program;
}
/*
* Function call
*/
if (!SCM_FALSEP (scm_procedure_p (program)))
if (!SCM_FALSEP (scm_procedure_p (x)))
{
POP_LIST (nargs);
*sp = scm_apply (program, *sp, SCM_EOL);
program = SCM_VM_FRAME_PROGRAM (fp);
sp[-1] = scm_apply (x, *sp, SCM_EOL);
sp--;
goto vm_return;
}
/*
* Continuation call
*/
if (SCM_VM_CONT_P (program))
if (SCM_VM_CONT_P (x))
goto vm_call_cc;
goto vm_error_wrong_type_apply;
}
VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
{
}
VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
{
SYNC_BEFORE_GC ();