*** empty log message ***

module/system/repl/command.scm

@@ -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))

module/system/vm/assemble.scm

@@ -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)
+	    (let ((bindings
-				(case (cadr v)
+		   (map (lambda (v)
-				  ((argument) (list (car v) #f (caddr v)))
+			  (let ((name (car v)) (type (cadr v)) (i (caddr v)))
-				  ((local) (list (car v) #f
+			    (case type
-						 (+ vars.nargs (caddr v))))
+			      ((argument) (make-binding name #f i))
-				  ((external) (list (car v) #t (caddr v)))))
+			      ((local) (make-binding name #f (+ vars.nargs i)))
-			      binds)))
+			      ((external) (make-binding name #t i)))))
-	      (set! bind-alist (acons (current-address) binds bind-alist))))
+			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)))

module/system/vm/conv.scm

@@ -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)

module/system/vm/core.scm

@@ -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)))
 

module/system/vm/debug.scm

@@ -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)))
+  (let ((chain (vm-last-frame-chain vm)))
-    (if (null? stack)
+    (if (null? chain)
       (display "No backtrace available\n")
-      (for-each print-frame (reverse! stack)))))
+      (for-each print-frame (reverse! chain)))))

module/system/vm/disasm.scm

@@ -32,8 +32,8 @@
 (define (disassemble-objcode objcode . opts)
   (let* ((prog  (objcode->program objcode))
 	 (arity (program-arity prog))
-	 (nlocs (caddr arity))
+	 (nlocs (arity:nlocs arity))
-	 (nexts (cadddr 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))
+	 (nargs (arity:nargs arity))
-	 (nrest (cadr arity))
+	 (nrest (arity:nrest arity))
-	 (nlocs (caddr arity))
+	 (nlocs (arity:nlocs arity))
-	 (nexts (cadddr arity))
+	 (nexts (arity:nexts arity))
 	 (bytes (program-bytecode prog))
 	 (objs  (program-objects prog))
 	 (exts  (program-external prog)))

module/system/vm/frame.scm

@@ -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)
+(define-public (vm-current-frame-chain vm)
-  (make-frame-stack (vm-last-frame vm) (vm:ip vm)))
+  (make-frame-chain (vm-this-frame vm) (vm:ip vm)))
 
-(define-public (vm-current-frame-stack vm)
+(define-public (vm-last-frame-chain vm)
-  (make-frame-stack (vm-current-frame vm) (vm:ip vm)))
+  (make-frame-chain (vm-last-frame vm) (vm:ip vm)))
 
-(define (make-frame-stack frame addr)
+(define (make-frame-chain frame addr)
-  (cond ((frame-dynamic-link frame) =>
+  (let ((link (frame-dynamic-link frame)))
-	 (lambda (link)
+    (if (eq? link #t)
-	   (let ((stack (make-frame-stack link (frame-return-address frame)))
+      '()
-		 (base (program-base (frame-program frame))))
+      (let ((chain (make-frame-chain link (frame-return-address frame)))
-	     (set! (frame-index frame) (1+ (length stack)))
+	    (base (program-base (frame-program frame))))
-	     (set! (frame-address frame) (- addr base))
+	(set! (frame-number frame) (1+ (length chain)))
-	     (cons frame stack))))
+	(set! (frame-address frame) (- addr base))
-	(else '())))
+	(cons frame chain)))))
-
-(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))))))
 
 
 ;;;
 ;;; Pretty printing
 ;;;
 
-(define-public (frame-call-list frame)
+(define-public (print-frame frame)
-  (let* ((prog (frame-program frame))
+  (format #t "#~A " (frame-number frame))
-	 (locs (vector->list (frame-local-variables frame)))
+  (print-frame-call frame)
-	 (args (list-truncate locs (car (program-arity prog))))
+  (newline))
-	 (name (or (frame-object-name (frame-dynamic-link frame) prog)
-		   (object-name prog))))
-    (cons name args)))
 
 (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)
+(define (program-name frame)
-  (format #t "#~A " (frame-index frame))
+  (let ((prog (frame-program frame))
-  (print-frame-call frame)
+	(link (frame-dynamic-link frame)))
-  (newline))
+    (or (object-property prog 'name)
-
+	(frame-object-name link (1- (frame-address link)) prog)
-(define (list-truncate l n)
+	(hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
-  (do ((i 0 (1+ i))
+		   prog (module-obarray (current-module))))))
-       (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)))))

module/system/vm/profile.scm

@@ -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)))
+	  (vm-load vm objcode)
-	    (display-result vm)
+	  (print-result vm))
-	    val))
 	(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

module/system/vm/trace.scm

@@ -23,54 +23,51 @@
   :use-syntax (system base syntax)
   :use-module (system vm core)
   :use-module (system vm frame)
-  :use-module (ice-9 format)
+  :use-module (ice-9 format))
-  :export (vm-trace vm-trace-on vm-trace-off))
 
-(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)))
+      ((:s) (puts (vm-fetch-stack vm)))
-      ((:v) (let ((stack (vm-current-frame-stack vm)))
+      ((:l) (puts (vm-fetch-locals vm)))
-	      (if (pair? stack)
+      ((:e) (puts (vm-fetch-externals vm))))))
-		(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)))))))
 
 (define (trace-apply vm)
-  ;;  (if (vm-option vm 'trace-first)
+  (if (vm-option vm 'trace-first)
-  ;;    (set-vm-option! vm 'trace-first #f)
+    (set-vm-option! vm 'trace-first #f)
-  (let ((stack (vm-current-frame-stack vm)))
+    (let ((chain (vm-current-frame-chain vm)))
-    (print-indent stack)
+      (print-indent chain)
-    (print-frame-call (car stack))
+      (print-frame-call (car chain))
-    (newline)))
+      (newline))))
 
 (define (trace-return vm)
-  (let ((stack (vm-current-frame-stack vm)))
+  (let ((chain (vm-current-frame-chain vm)))
-    (print-indent stack)
+    (print-indent chain)
     (write (vm-return-value vm))
     (newline)))
 
-(define (print-indent stack)
+(define (print-indent chain)
-  (cond ((pair? stack) (display "| ") (print-indent (cdr stack)))))
+  (cond ((pair? (cdr chain))
+	 (display "| ")
+	 (print-indent (cdr chain)))))

src/frames.c

@@ -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 frame;
-    scm_must_malloc (sizeof (struct scm_heap_frame), "make_heap_frame");
+  SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
-  p->fp            = fp;
+  SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
-  p->program       = SCM_UNDEFINED;
+  size_t size = sizeof (SCM) * (upper - lower + 1);
-  p->variables     = SCM_UNDEFINED;
+  SCM *p = scm_must_malloc (size, "scm_c_make_heap_frame");
-  p->dynamic_link  = SCM_UNDEFINED;
+  SCM_NEWSMOB (frame, scm_tc16_heap_frame, p);
-  p->external_link = SCM_UNDEFINED;
+  p[0] = frame; /* self link */
-  SCM_RETURN_NEWSMOB (scm_tc16_heap_frame, p);
+  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 *sp;
-  scm_gc_mark (p->program);
+  SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
-  scm_gc_mark (p->variables);
+  SCM *limit = &SCM_FRAME_HEAP_LINK (fp);
-  scm_gc_mark (p->dynamic_link);
+
-  return p->external_link;
+  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_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
-	    (SCM frame),
+	    (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_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
-    {
+	    (SCM frame, SCM index, SCM val),
-      SCM prog = scm_frame_program (frame);
+	    "")
-      struct scm_program *pp = SCM_PROGRAM_DATA (prog);
+#define FUNC_NAME s_scm_frame_local_set_x
-      int i, size = pp->nargs + pp->nlocs;
+{
-      p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
-      for (i = 0; i < size; i++)
+  SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
-	SCM_VELTS (p->variables)[i] = SCM_STACK_FRAME_VARIABLE (p->fp, i);
+  SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame), SCM_INUM (index)) = val;
-    }
+  return SCM_UNSPECIFIED;
-  return p->variables;
 }
 #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_ulong2num ((unsigned long) (SCM_FRAME_RETURN_ADDRESS
-  return scm_long2num ((long) SCM_VM_BYTE_ADDRESS
+					 (SCM_HEAP_FRAME_POINTER (frame))));
-		       (SCM_STACK_FRAME_RETURN_ADDRESS
-			(SCM_HEAP_FRAME_DATA (frame)->fp)));
 }
 #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);
+  return SCM_FRAME_HEAP_LINK (SCM_HEAP_FRAME_POINTER (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;
 }
 #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);
+  return SCM_FRAME_EXTERNAL_LINK (SCM_HEAP_FRAME_POINTER (frame));
-
-  if (SCM_UNBNDP (p->external_link))
-    p->external_link = SCM_STACK_FRAME_EXTERNAL_LINK (p->fp);
-
-  return p->external_link;
 }
 #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"

src/frames.h

@@ -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 + 4
-   |                  | <- fp + bp->nargs + bp->nlocs + 3
+   +------------------+    = SCM_FRAME_UPPER_ADDRESS (fp)
-   +------------------+    = SCM_STACK_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)			\
+#define SCM_FRAME_DATA_ADDRESS(fp)				\
-  (fp + SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nargs	\
+  (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs	\
-      + SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nlocs)
+      + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
-#define SCM_STACK_FRAME_UPPER_ADDRESS(fp)			\
+#define SCM_FRAME_UPPER_ADDRESS(fp)	(SCM_FRAME_DATA_ADDRESS (fp) + 4)
-  (SCM_STACK_FRAME_DATA_ADDRESS (fp) + 3)
+#define SCM_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
-#define SCM_STACK_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
 
-#define SCM_STACK_FRAME_RETURN_ADDRESS(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[2]
+#define SCM_FRAME_BYTE_CAST(x)		((scm_byte_t *) SCM_UNPACK (x))
-#define SCM_STACK_FRAME_DYNAMIC_LINK(fp)   SCM_STACK_FRAME_DATA_ADDRESS (fp)[1]
+#define SCM_FRAME_STACK_CAST(x)		((SCM *) SCM_UNPACK (x))
-#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_FRAME_RETURN_ADDRESS(fp)	SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3])
-#define SCM_STACK_FRAME_PROGRAM(fp)	   fp[-1]
+#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);
 

src/vm.c

@@ -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 */
+  /* mark the stack conservatively */
-  sp = vp->sp;
+  scm_mark_locations ((SCM_STACKITEM *) vp->stack_base,
-  fp = vp->fp;
+		      sizeof (SCM) * (vp->sp - vp->stack_base + 1));
-  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 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)[0] = scm_ulong2num (SCM_VM_DATA (vm)->time);
-  SCM_VELTS (stats)[1] = scm_long2num (SCM_VM_DATA (vm)->clock);
+  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_VM_DATA (vm)->this_frame;
-  return scm_c_make_heap_frame (SCM_VM_DATA (vm)->fp);
 }
 #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;
 }

src/vm.h

@@ -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_ */

src/vm_engine.c

@@ -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);
   }
 

src/vm_engine.h

@@ -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 ra = SCM_PACK (ip);			\
-  SCM dl = SCM_VM_MAKE_STACK_ADDRESS (fp);	\
+  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;					\
+  if (!SCM_FALSEP (p[1]))			\
-  ip = SCM_VM_BYTE_ADDRESS (p[2]);		\
+    vp->this_frame = p[1];			\
-  fp = SCM_VM_STACK_ADDRESS (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

src/vm_system.c

@@ -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_REF(i)		SCM_FRAME_VARIABLE (fp, i)
-#define LOCAL_SET(i,o)		SCM_STACK_FRAME_VARIABLE (fp, i) = o
+#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;
 }