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

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-23 04:28:13 +00:00
parent e74a58f20e
commit af988bbf9c
16 changed files with 395 additions and 276 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -27,10 +27,9 @@
:autoload (system base language) (lookup-language)
:autoload (system il glil) (pprint-glil)
:autoload (system vm disasm) (disassemble-program disassemble-objcode)
:autoload (system vm debug) (vm-debugger vm-backtrace)
:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
:autoload (system vm profile) (vm-profile)
:autoload (system vm debugger) (vm-debugger)
:autoload (system vm backtrace) (vm-backtrace)
:use-module (ice-9 format)
:use-module (ice-9 session)
:use-module (ice-9 documentation))

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

@ -71,7 +71,7 @@
(match glil
(($ <vm-asm> venv ($ <glil-asm> vars _) body)
(let ((stack '())
(bind-alist '())
(binding-alist '())
(source-alist '())
(label-alist '())
(object-alist '()))
@ -99,17 +99,19 @@
(if venv.closure? (push-code! `(make-closure))))
(($ <glil-bind> binds)
(let ((binds (map (lambda (v)
(case (cadr v)
((argument) (list (car v) #f (caddr v)))
((local) (list (car v) #f
(+ vars.nargs (caddr v))))
((external) (list (car v) #t (caddr v)))))
binds)))
(set! bind-alist (acons (current-address) binds bind-alist))))
(let ((bindings
(map (lambda (v)
(let ((name (car v)) (type (cadr v)) (i (caddr v)))
(case type
((argument) (make-binding name #f i))
((local) (make-binding name #f (+ vars.nargs i)))
((external) (make-binding name #t i)))))
binds)))
(set! binding-alist
(acons (current-address) bindings binding-alist))))
(($ <glil-unbind>)
(set! bind-alist (acons (current-address) #f bind-alist)))
(set! binding-alist (acons (current-address) #f binding-alist)))
(($ <glil-source> loc)
(set! source-alist (acons (current-address) loc source-alist)))
@ -168,10 +170,10 @@
(if toplevel
(bytecode->objcode bytes vars.nlocs vars.nexts)
(<bytespec> :vars vars :bytes bytes
:meta (if (and (null? bind-alist)
:meta (if (and (null? binding-alist)
(null? source-alist))
#f
(cons (reverse! bind-alist)
(cons (reverse! binding-alist)
(reverse! source-alist)))
:objs (let ((objs (map car (reverse! object-alist))))
(if (null? objs) #f (list->vector objs)))

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

@ -130,7 +130,7 @@
;;; Variable-length interface
;;;
;; NOTE: decoded in vm_fetch_length in vm.c.
;; NOTE: decoded in vm_fetch_length in vm.c as well.
(define (encode-length len)
(define C integer->char)

115
module/system/vm/core.scm
View file

@ -21,7 +21,6 @@
(define-module (system vm core))
;;;
;;; Core procedures
;;;
@ -35,9 +34,21 @@
;;;
;;; High-level procedures
;;; Programs
;;;
(define-public arity:nargs car)
(define-public arity:nrest cadr)
(define-public arity:nlocs caddr)
(define-public arity:nexts cadddr)
(define-public (make-binding name extp index)
(list name extp index))
(define-public binding:name car)
(define-public binding:extp cadr)
(define-public binding:index caddr)
(define-public (program-bindings prog)
(cond ((program-meta prog) => car)
(else '())))
@ -46,9 +57,109 @@
(cond ((program-meta prog) => cdr)
(else '())))
;;;
;;; Frames
;;;
(define-public (frame-arguments frame)
(let* ((prog (frame-program frame))
(arity (program-arity prog)))
(do ((n (+ (arity:nargs arity) -1) (1- n))
(l '() (cons (frame-local-ref frame n) l)))
((< n 0) l))))
(define-public (frame-local-variables frame)
(let* ((prog (frame-program frame))
(arity (program-arity prog)))
(do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
(l '() (cons (frame-local-ref frame n) l)))
((< n 0) l))))
(define-public (frame-external-variables frame)
(frame-external-link frame))
(define (frame-external-ref frame index)
(list-ref (frame-external-link frame) index))
(define (frame-external-set! frame index val)
(list-set! (frame-external-link frame) index val))
(define (frame-binding-ref frame binding)
(if (binding:extp binding)
(frame-external-ref frame (binding:index binding))
(frame-local-ref frame (binding:index binding))))
(define (frame-binding-set! frame binding val)
(if (binding:extp binding)
(frame-external-set! frame (binding:index binding) val)
(frame-local-set! frame (binding:index binding) val)))
(define (frame-bindings frame addr)
(do ((bs (program-bindings (frame-program frame)) (cdr bs))
(ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
((or (null? bs) (> (caar bs) addr))
(apply append ls))))
(define (frame-lookup-binding frame addr sym)
(do ((bs (frame-bindings frame addr) (cdr bs)))
((or (null? bs) (eq? sym (binding:name (car bs))))
(and (pair? bs) (car bs)))))
(define (frame-object-binding frame addr obj)
(do ((bs (frame-bindings frame addr) (cdr bs)))
((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
(and (pair? bs) (car bs)))))
(define-public (frame-environment frame addr)
(map (lambda (binding)
(cons (binding:name binding) (frame-binding-ref frame binding)))
(frame-bindings frame addr)))
(define-public (frame-variable-exists? frame addr sym)
(if (frame-lookup-binding frame addr sym) #t #f))
(define-public (frame-variable-ref frame addr sym)
(cond ((frame-lookup-binding frame addr sym) =>
(lambda (binding) (frame-binding-ref frame binding)))
(else (error "Unknown variable:" sym))))
(define-public (frame-variable-set! frame addr sym val)
(cond ((frame-lookup-binding frame addr sym) =>
(lambda (binding) (frame-binding-set! frame binding val)))
(else (error "Unknown variable:" sym))))
(define-public (frame-object-name frame addr obj)
(cond ((frame-object-binding frame addr obj) => binding:name)
(else #f)))
;;;
;;; Current status
;;;
(define-public (vm-fetch-locals vm)
(frame-local-variables (vm-this-frame vm)))
(define-public (vm-fetch-externals vm)
(frame-external-variables (vm-this-frame vm)))
(define-public (vm-return-value vm)
(car (vm-fetch-stack vm)))
;;;
;;; Statistics
;;;
(define-public (vms:time stat) (vector-ref stat 0))
(define-public (vms:clock stat) (vector-ref stat 1))
;;;
;;; Loader
;;;
(define-public (vm-load vm objcode)
(vm (objcode->program objcode)))

42
module/system/vm/backtrace.scm → module/system/vm/debug.scm
View file

@ -1,4 +1,4 @@
;;; Guile VM backtrace
;;; Guile VM debugging facilities
;; Copyright (C) 2001 Free Software Foundation, Inc.
@ -19,15 +19,45 @@
;;; Code:
(define-module (system vm backtrace)
(define-module (system vm debug)
:use-syntax (system base syntax)
:use-module (system vm core)
:use-module (system vm frame)
:use-module (ice-9 format)
:export (vm-backtrace))
:export (vm-debugger vm-backtrace))
;;;
;;; Debugger
;;;
(define-record (<debugger> vm chain index))
(define (vm-debugger vm)
(let ((chain (vm-last-frame-chain vm)))
(if (null? chain)
(display "Nothing to debug\n")
(debugger-repl (<debugger> :vm vm :chain chain :index (length chain))))))
(define (debugger-repl db)
(let loop ()
(display "debug> ")
(let ((cmd (read)))
(case cmd
((bt) (vm-backtrace db.vm))
((stack)
(write (vm-fetch-stack db.vm))
(newline))
(else
(format #t "Unknown command: ~A" cmd))))))
;;;
;;; Backtrace
;;;
(define (vm-backtrace vm)
(let ((stack (vm-last-frame-stack vm)))
(if (null? stack)
(let ((chain (vm-last-frame-chain vm)))
(if (null? chain)
(display "No backtrace available\n")
(for-each print-frame (reverse! stack)))))
(for-each print-frame (reverse! chain)))))

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

@ -32,8 +32,8 @@
(define (disassemble-objcode objcode . opts)
(let* ((prog (objcode->program objcode))
(arity (program-arity prog))
(nlocs (caddr arity))
(nexts (cadddr arity))
(nlocs (arity:nlocs arity))
(nexts (arity:nexts arity))
(bytes (program-bytecode prog)))
(format #t "Disassembly of ~A:\n\n" objcode)
(format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts)
@ -41,10 +41,10 @@
(define (disassemble-program prog . opts)
(let* ((arity (program-arity prog))
(nargs (car arity))
(nrest (cadr arity))
(nlocs (caddr arity))
(nexts (cadddr arity))
(nargs (arity:nargs arity))
(nrest (arity:nrest arity))
(nlocs (arity:nlocs arity))
(nexts (arity:nexts arity))
(bytes (program-bytecode prog))
(objs (program-objects prog))
(exts (program-external prog)))

101
module/system/vm/frame.scm
View file

@ -22,78 +22,39 @@
(define-module (system vm frame)
:use-module (system vm core))
(define-public (vm-return-value vm)
(car (vm-fetch-stack vm)))
(define-public (frame-local-ref frame index)
(vector-ref (frame-local-variables frame) index))
(define-public (frame-external-ref frame index)
(list-ref (frame-external-link frame) index))
;;;
;;; Debug frames
;;; Frame chain
;;;
(define-public frame-index (make-object-property))
(define-public frame-number (make-object-property))
(define-public frame-address (make-object-property))
(define-public (vm-last-frame-stack vm)
(make-frame-stack (vm-last-frame vm) (vm:ip vm)))
(define-public (vm-current-frame-chain vm)
(make-frame-chain (vm-this-frame vm) (vm:ip vm)))
(define-public (vm-current-frame-stack vm)
(make-frame-stack (vm-current-frame vm) (vm:ip vm)))
(define-public (vm-last-frame-chain vm)
(make-frame-chain (vm-last-frame vm) (vm:ip vm)))
(define (make-frame-stack frame addr)
(cond ((frame-dynamic-link frame) =>
(lambda (link)
(let ((stack (make-frame-stack link (frame-return-address frame)))
(base (program-base (frame-program frame))))
(set! (frame-index frame) (1+ (length stack)))
(set! (frame-address frame) (- addr base))
(cons frame stack))))
(else '())))
(define-public (frame-bindings frame addr)
(do ((bs (program-bindings (frame-program frame)) (cdr bs))
(ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
((or (null? bs) (> (caar bs) addr))
(apply append ls))))
(define-public (frame-environment frame addr)
(map (lambda (binding)
(let ((name (car binding))
(extp (cadr binding))
(index (caddr binding)))
(cons name (if extp
(frame-external-ref frame index)
(frame-local-ref frame index)))))
(frame-bindings frame addr)))
(define (frame-variable-ref frame sym)
(cond ((assq sym (frame-environment frame)) => cdr)
(else (error "Unbound"))))
(define (frame-object-name frame obj)
(display (frame-address frame))
(let loop ((alist (frame-environment frame (frame-address frame))))
(cond ((null? alist) #f)
((eq? obj (cdar alist)) (caar alist))
(else (loop (cdr alist))))))
(define (make-frame-chain frame addr)
(let ((link (frame-dynamic-link frame)))
(if (eq? link #t)
'()
(let ((chain (make-frame-chain link (frame-return-address frame)))
(base (program-base (frame-program frame))))
(set! (frame-number frame) (1+ (length chain)))
(set! (frame-address frame) (- addr base))
(cons frame chain)))))
;;;
;;; Pretty printing
;;;
(define-public (frame-call-list frame)
(let* ((prog (frame-program frame))
(locs (vector->list (frame-local-variables frame)))
(args (list-truncate locs (car (program-arity prog))))
(name (or (frame-object-name (frame-dynamic-link frame) prog)
(object-name prog))))
(cons name args)))
(define-public (print-frame frame)
(format #t "#~A " (frame-number frame))
(print-frame-call frame)
(newline))
(define-public (print-frame-call frame)
(define (abbrev x)
@ -106,20 +67,12 @@
((1) (vector (abbrev (vector-ref x 0))))
(else (vector (abbrev (vector-ref x 0)) '...))))
(else x)))
(write (abbrev (frame-call-list frame))))
(write (abbrev (cons (program-name frame) (frame-arguments frame)))))
(define-public (print-frame frame)
(format #t "#~A " (frame-index frame))
(print-frame-call frame)
(newline))
(define (list-truncate l n)
(do ((i 0 (1+ i))
(l l (cdr l))
(r '() (cons (car l) r)))
((= i n) (reverse! r))))
(define (object-name x)
(or (object-property x 'name)
(hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d))
x (module-obarray (current-module)))))
(define (program-name frame)
(let ((prog (frame-program frame))
(link (frame-dynamic-link frame)))
(or (object-property prog 'name)
(frame-object-name link (1- (frame-address link)) prog)
(hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
prog (module-obarray (current-module))))))

7
module/system/vm/profile.scm
View file

@ -34,9 +34,8 @@
(add-hook! (vm-enter-hook vm) profile-enter)
(add-hook! (vm-exit-hook vm) profile-exit))
(lambda ()
(let ((val (vm-load vm objcode)))
(display-result vm)
val))
(vm-load vm objcode)
(print-result vm))
(lambda ()
(set-vm-option! vm 'debug flag)
(remove-hook! (vm-next-hook vm) profile-next)
@ -53,7 +52,7 @@
(define (profile-exit vm)
#f)
(define (display-result vm . opts)
(define (print-result vm . opts)
(do ((data (vm-option vm 'profile-data) (cdr data))
(summary '() (let ((inst (caar data)))
(assq-set! summary inst

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

@ -23,54 +23,51 @@
:use-syntax (system base syntax)
:use-module (system vm core)
:use-module (system vm frame)
:use-module (ice-9 format)
:export (vm-trace vm-trace-on vm-trace-off))
:use-module (ice-9 format))
(define (vm-trace vm objcode . opts)
(define-public (vm-trace vm objcode . opts)
(dynamic-wind
(lambda () (apply vm-trace-on vm opts))
(lambda () (vm-load vm objcode))
(lambda () (apply vm-trace-off vm opts))))
(define (vm-trace-on vm . opts)
(define-public (vm-trace-on vm . opts)
(set-vm-option! vm 'trace-first #t)
(if (memq :b opts) (add-hook! (vm-next-hook vm) trace-next))
(set-vm-option! vm 'trace-options opts)
(add-hook! (vm-apply-hook vm) trace-apply)
(add-hook! (vm-return-hook vm) trace-return))
(define (vm-trace-off vm . opts)
(define-public (vm-trace-off vm . 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))
(define (trace-next vm)
(format #t "0x~8X ~20S" (vm:ip vm) (vm-fetch-code vm))
(define (puts x) (display #\tab) (write x))
(format #t "0x~8X ~16S" (vm:ip vm) (vm-fetch-code vm))
(do ((opts (vm-option vm 'trace-options) (cdr opts)))
((null? opts) (newline))
(case (car opts)
((:s) (format #t "~20S" (vm-fetch-stack vm)))
((:v) (let ((stack (vm-current-frame-stack vm)))
(if (pair? stack)
(format #t "~20S" (frame-environment (car stack))))))
((:l)
(format #t "~20S" (frame-local-variables (vm-current-frame vm))))
((:e)
(format #t "~20A" (frame-external-link (vm-current-frame vm)))))))
((:s) (puts (vm-fetch-stack vm)))
((:l) (puts (vm-fetch-locals vm)))
((:e) (puts (vm-fetch-externals vm))))))
(define (trace-apply vm)
;; (if (vm-option vm 'trace-first)
;; (set-vm-option! vm 'trace-first #f)
(let ((stack (vm-current-frame-stack vm)))
(print-indent stack)
(print-frame-call (car stack))
(newline)))
(if (vm-option vm 'trace-first)
(set-vm-option! vm 'trace-first #f)
(let ((chain (vm-current-frame-chain vm)))
(print-indent chain)
(print-frame-call (car chain))
(newline))))
(define (trace-return vm)
(let ((stack (vm-current-frame-stack vm)))
(print-indent stack)
(let ((chain (vm-current-frame-chain vm)))
(print-indent chain)
(write (vm-return-value vm))
(newline)))
(define (print-indent stack)
(cond ((pair? stack) (display "| ") (print-indent (cdr stack)))))
(define (print-indent chain)
(cond ((pair? (cdr chain))
(display "| ")
(print-indent (cdr chain)))))

110
src/frames.c
View file

@ -48,24 +48,40 @@ scm_bits_t scm_tc16_heap_frame;
SCM
scm_c_make_heap_frame (SCM *fp)
{
struct scm_heap_frame *p =
scm_must_malloc (sizeof (struct scm_heap_frame), "make_heap_frame");
p->fp = fp;
p->program = SCM_UNDEFINED;
p->variables = SCM_UNDEFINED;
p->dynamic_link = SCM_UNDEFINED;
p->external_link = SCM_UNDEFINED;
SCM_RETURN_NEWSMOB (scm_tc16_heap_frame, p);
SCM frame;
SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
size_t size = sizeof (SCM) * (upper - lower + 1);
SCM *p = scm_must_malloc (size, "scm_c_make_heap_frame");
SCM_NEWSMOB (frame, scm_tc16_heap_frame, p);
p[0] = frame; /* self link */
memcpy (p + 1, lower, size - sizeof (SCM));
return frame;
}
static SCM
heap_frame_mark (SCM obj)
{
struct scm_heap_frame *p = SCM_HEAP_FRAME_DATA (obj);
scm_gc_mark (p->program);
scm_gc_mark (p->variables);
scm_gc_mark (p->dynamic_link);
return p->external_link;
SCM *sp;
SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
SCM *limit = &SCM_FRAME_HEAP_LINK (fp);
for (sp = SCM_FRAME_LOWER_ADDRESS (fp); sp <= limit; sp++)
if (SCM_NIMP (*sp))
scm_gc_mark (*sp);
return SCM_BOOL_F;
}
static scm_sizet
heap_frame_free (SCM obj)
{
SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
size_t size = sizeof (SCM) * (upper - lower + 1);
scm_must_free (SCM_HEAP_FRAME_DATA (obj));
return size;
}
/* Scheme interface */
@ -85,30 +101,31 @@ SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
#define FUNC_NAME s_scm_frame_program
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
return SCM_STACK_FRAME_PROGRAM (SCM_HEAP_FRAME_DATA (frame)->fp);
return SCM_FRAME_PROGRAM (SCM_HEAP_FRAME_POINTER (frame));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_local_variables, "frame-local-variables", 1, 0, 0,
(SCM frame),
SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
"")
#define FUNC_NAME s_scm_frame_local_variables
#define FUNC_NAME s_scm_frame_local_ref
{
struct scm_heap_frame *p;
SCM_VALIDATE_HEAP_FRAME (1, frame);
p = SCM_HEAP_FRAME_DATA (frame);
SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
SCM_INUM (index));
}
#undef FUNC_NAME
if (SCM_UNBNDP (p->variables))
{
SCM prog = scm_frame_program (frame);
struct scm_program *pp = SCM_PROGRAM_DATA (prog);
int i, size = pp->nargs + pp->nlocs;
p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
for (i = 0; i < size; i++)
SCM_VELTS (p->variables)[i] = SCM_STACK_FRAME_VARIABLE (p->fp, i);
}
return p->variables;
SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
"")
#define FUNC_NAME s_scm_frame_local_set_x
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame), SCM_INUM (index)) = val;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -118,10 +135,8 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
return scm_long2num ((long) SCM_VM_BYTE_ADDRESS
(SCM_STACK_FRAME_RETURN_ADDRESS
(SCM_HEAP_FRAME_DATA (frame)->fp)));
return scm_ulong2num ((unsigned long) (SCM_FRAME_RETURN_ADDRESS
(SCM_HEAP_FRAME_POINTER (frame))));
}
#undef FUNC_NAME
@ -130,21 +145,8 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_dynamic_link
{
struct scm_heap_frame *p;
SCM_VALIDATE_HEAP_FRAME (1, frame);
p = SCM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->dynamic_link))
{
SCM *fp = SCM_VM_STACK_ADDRESS (SCM_STACK_FRAME_DYNAMIC_LINK (p->fp));
if (fp)
p->dynamic_link = scm_c_make_heap_frame (fp);
else
p->dynamic_link = SCM_BOOL_F;
}
return p->dynamic_link;
return SCM_FRAME_HEAP_LINK (SCM_HEAP_FRAME_POINTER (frame));
}
#undef FUNC_NAME
@ -153,15 +155,8 @@ SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_external_link
{
struct scm_heap_frame *p;
SCM_VALIDATE_HEAP_FRAME (1, frame);
p = SCM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->external_link))
p->external_link = SCM_STACK_FRAME_EXTERNAL_LINK (p->fp);
return p->external_link;
return SCM_FRAME_EXTERNAL_LINK (SCM_HEAP_FRAME_POINTER (frame));
}
#undef FUNC_NAME
@ -169,8 +164,9 @@ SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
void
scm_init_frames (void)
{
scm_tc16_heap_frame = scm_make_smob_type ("heap_frame", 0);
scm_tc16_heap_frame = scm_make_smob_type ("frame", 0);
scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free);
#ifndef SCM_MAGIC_SNARFER
#include "frames.x"

68
src/frames.h
View file

@ -46,74 +46,56 @@
#include "config.h"
#include "programs.h"
/*
* VM Address
*/
#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 Stack frames
* VM frames
*/
/* Stack frames are allocated on the VM stack as follows:
| | <- fp + bp->nargs + bp->nlocs + 3
+------------------+ = SCM_STACK_FRAME_UPPER_ADDRESS (fp)
/*
| | <- fp + bp->nargs + bp->nlocs + 4
+------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
| Return address |
| Dynamic link |
| Heap link |
| External link | <- fp + bp->nargs + bp->nlocs
| Local varialbe 1 | = SCM_STACK_FRAME_DATA_ADDRESS (fp)
| Local varialbe 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
+------------------+ = SCM_STACK_FRAME_LOWER_ADDRESS (fp)
+------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
| |
*/
#define SCM_STACK_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nargs \
+ SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nlocs)
#define SCM_STACK_FRAME_UPPER_ADDRESS(fp) \
(SCM_STACK_FRAME_DATA_ADDRESS (fp) + 3)
#define SCM_STACK_FRAME_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_STACK_FRAME_RETURN_ADDRESS(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[2]
#define SCM_STACK_FRAME_DYNAMIC_LINK(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[1]
#define SCM_STACK_FRAME_EXTERNAL_LINK(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[0]
#define SCM_STACK_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_STACK_FRAME_PROGRAM(fp) fp[-1]
#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
#define SCM_FRAME_RETURN_ADDRESS(fp) SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3])
#define SCM_FRAME_DYNAMIC_LINK(fp) SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2])
#define SCM_FRAME_HEAP_LINK(fp) SCM_FRAME_DATA_ADDRESS (fp)[1]
#define SCM_FRAME_EXTERNAL_LINK(fp) SCM_FRAME_DATA_ADDRESS (fp)[0]
#define SCM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_FRAME_PROGRAM(fp) fp[-1]
/*
* VM Heap frames
* Heap frames
*/
struct scm_heap_frame {
SCM *fp;
SCM program;
SCM variables;
SCM dynamic_link;
SCM external_link;
};
extern scm_bits_t scm_tc16_heap_frame;
#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
#define SCM_HEAP_FRAME_DATA(f) ((struct scm_heap_frame *) SCM_SMOB_DATA (f))
#define SCM_HEAP_FRAME_DATA(f) ((SCM *) SCM_SMOB_DATA (f))
#define SCM_HEAP_FRAME_SELF(f) (SCM_HEAP_FRAME_DATA (f)[0])
#define SCM_HEAP_FRAME_POINTER(f) (SCM_HEAP_FRAME_DATA (f) + 2)
#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
#define SCM_HEAP_FRAME_PROGRAM(f) SCM_HEAP_FRAME_DATA (f)->program
#define SCM_HEAP_FRAME_VARIABLES(f) SCM_HEAP_FRAME_DATA (f)->variables
#define SCM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_HEAP_FRAME_DATA (f)->dynamic_link
#define SCM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_HEAP_FRAME_DATA (f)->external_link
extern SCM scm_c_make_heap_frame (SCM *fp);
extern void scm_init_frames (void);

95
src/vm.c
View file

@ -148,6 +148,63 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp)
return ip;
}
static SCM
vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *limit, SCM **basep)
{
SCM *base, frame;
SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
SCM *sp = SCM_FRAME_UPPER_ADDRESS (fp);
if (!dl)
{
/* The top frame */
base = vp->stack_base;
frame = scm_c_make_heap_frame (fp);
fp = SCM_HEAP_FRAME_POINTER (frame);
SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
}
else
{
/* Other frames */
SCM link = SCM_FRAME_HEAP_LINK (dl);
if (!SCM_FALSEP (link))
{
link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
base = SCM_FRAME_LOWER_ADDRESS (fp);
}
else
{
link = vm_heapify_frames_1 (vp, dl, SCM_FRAME_LOWER_ADDRESS (fp),
&base);
}
frame = scm_c_make_heap_frame (fp);
fp = SCM_HEAP_FRAME_POINTER (frame);
SCM_FRAME_HEAP_LINK (fp) = link;
SCM_FRAME_DYNAMIC_LINK (fp) = SCM_HEAP_FRAME_POINTER (link);
}
/* Move stack data */
for (; sp < limit; base++, sp++)
*base = *sp;
*basep = base;
return frame;
}
static SCM
vm_heapify_frames (SCM vm)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
{
SCM *base;
vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp + 1, &base);
vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
vp->sp = base - 1;
}
return vp->this_frame;
}
/*
* VM
@ -191,6 +248,7 @@ make_vm (void)
vp->time = 0;
vp->clock = 0;
vp->options = SCM_EOL;
vp->this_frame = SCM_BOOL_F;
vp->last_frame = SCM_BOOL_F;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
@ -202,30 +260,16 @@ static SCM
vm_mark (SCM obj)
{
int i;
SCM *sp, *fp;
struct scm_vm *vp = SCM_VM_DATA (obj);
/* Mark the stack */
sp = vp->sp;
fp = vp->fp;
while (fp)
{
SCM *upper = SCM_STACK_FRAME_UPPER_ADDRESS (fp);
SCM *lower = SCM_STACK_FRAME_LOWER_ADDRESS (fp);
/* Mark intermediate data */
for (; sp >= upper; sp--)
if (SCM_NIMP (*sp))
scm_gc_mark (*sp);
fp = SCM_VM_STACK_ADDRESS (sp[-1]); /* dynamic link */
/* Mark external link, frame variables, and program */
for (sp -= 2; sp >= lower; sp--)
if (SCM_NIMP (*sp))
scm_gc_mark (*sp);
}
/* mark the stack conservatively */
scm_mark_locations ((SCM_STACKITEM *) vp->stack_base,
sizeof (SCM) * (vp->sp - vp->stack_base + 1));
/* Mark the options */
/* mark other objects */
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
scm_gc_mark (vp->hooks[i]);
scm_gc_mark (vp->this_frame);
scm_gc_mark (vp->last_frame);
return vp->options;
}
@ -425,8 +469,8 @@ SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
SCM_VALIDATE_VM (1, vm);
stats = scm_c_make_vector (2, SCM_MAKINUM (0));
SCM_VELTS (stats)[0] = scm_long2num (SCM_VM_DATA (vm)->time);
SCM_VELTS (stats)[1] = scm_long2num (SCM_VM_DATA (vm)->clock);
SCM_VELTS (stats)[0] = scm_ulong2num (SCM_VM_DATA (vm)->time);
SCM_VELTS (stats)[1] = scm_ulong2num (SCM_VM_DATA (vm)->clock);
return stats;
}
@ -436,14 +480,13 @@ SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
if (!SCM_VM_DATA (vm)->ip) \
SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
(SCM vm),
"")
#define FUNC_NAME s_scm_vm_current_frame
#define FUNC_NAME s_scm_vm_this_frame
{
SCM_VALIDATE_VM (1, vm);
VM_CHECK_RUNNING (vm);
return scm_c_make_heap_frame (SCM_VM_DATA (vm)->fp);
return SCM_VM_DATA (vm)->this_frame;
}
#undef FUNC_NAME
@ -493,7 +536,7 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
VM_CHECK_RUNNING (vm);
vp = SCM_VM_DATA (vm);
for (sp = SCM_STACK_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++)
for (sp = vp->stack_base; sp <= vp->sp; sp++)
ls = scm_cons (*sp, ls);
return ls;
}

5
src/vm.h
View file

@ -61,9 +61,10 @@ struct scm_vm {
size_t stack_size; /* stack size */
SCM *stack_base; /* stack base address */
SCM *stack_limit; /* stack limit address */
SCM this_frame; /* currrent frame */
SCM last_frame; /* last frame */
SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
SCM options; /* options */
SCM last_frame; /* last frame */
unsigned long time; /* time spent */
unsigned long clock; /* bogos clock */
};
@ -78,8 +79,6 @@ extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
extern SCM scm_vm_option_ref (SCM vm, SCM key);
extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
extern SCM scm_vm_current_frame (SCM vm);
extern void scm_init_vm (void);
#endif /* _SCM_VM_H_ */

2
src/vm_engine.c
View file

@ -167,7 +167,7 @@ vm_run (SCM vm, SCM program, SCM args)
vm_error:
SYNC_ALL ();
vp->last_frame = scm_vm_current_frame (vm);
vp->last_frame = vm_heapify_frames (vm);
scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1);
}

26
src/vm_engine.h
View file

@ -170,8 +170,10 @@
{ \
if (!SCM_FALSEP (vp->hooks[h])) \
{ \
SYNC_BEFORE_GC (); \
SYNC_REGISTER (); \
vm_heapify_frames (vm); \
scm_c_run_hook (vp->hooks[h], hook_args); \
CACHE_REGISTER (); \
} \
}
#else
@ -291,15 +293,15 @@ do { \
#define NEW_FRAME() \
{ \
int i; \
SCM ra = SCM_VM_MAKE_BYTE_ADDRESS (ip); \
SCM dl = SCM_VM_MAKE_STACK_ADDRESS (fp); \
SCM ra = SCM_PACK (ip); \
SCM dl = SCM_PACK (fp); \
SCM *p = sp + 1; \
SCM *q = p + bp->nlocs; \
\
/* New pointers */ \
ip = bp->base; \
fp = p - bp->nargs; \
sp = q + 2; \
sp = q + 3; \
CHECK_OVERFLOW (); \
\
/* Init local variables */ \
@ -312,19 +314,25 @@ do { \
CONS (external, SCM_UNDEFINED, external); \
\
/* Set frame data */ \
p[3] = ra; \
p[2] = dl; \
p[1] = SCM_BOOL_F; \
p[0] = external; \
p[1] = dl; \
p[2] = ra; \
}
#define FREE_FRAME() \
{ \
SCM *p = fp + bp->nargs + bp->nlocs; \
sp = fp - 2; \
ip = SCM_VM_BYTE_ADDRESS (p[2]); \
fp = SCM_VM_STACK_ADDRESS (p[1]); \
if (!SCM_FALSEP (p[1])) \
vp->this_frame = p[1]; \
else \
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; \
fp = SCM_FRAME_STACK_CAST (p[2]); \
ip = SCM_FRAME_BYTE_CAST (p[3]); \
}
#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
/*
* Function support

12
src/vm_system.c
View file

@ -187,8 +187,8 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
#define OBJECT_REF(i) objects[i]
#define OBJECT_SET(i,o) objects[i] = o
#define LOCAL_REF(i) SCM_STACK_FRAME_VARIABLE (fp, i)
#define LOCAL_SET(i,o) SCM_STACK_FRAME_VARIABLE (fp, i) = o
#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
#define VARIABLE_REF(v) SCM_CDR (v)
#define VARIABLE_SET(v,o) SCM_SETCDR (v, o)
@ -379,7 +379,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
EXIT_HOOK ();
reinstate_vm_cont (vp, x);
CACHE_REGISTER ();
program = SCM_STACK_FRAME_PROGRAM (fp);
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
NEXT;
}
@ -490,15 +490,15 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
{
SCM ret;
vm_return:
ret = *sp;
POP (ret);
EXIT_HOOK ();
RETURN_HOOK ();
FREE_FRAME ();
/* Restore the last program */
program = SCM_STACK_FRAME_PROGRAM (fp);
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
external = fp[bp->nargs + bp->nlocs];
CACHE_EXTERNAL ();
PUSH (ret);
NEXT;
}