mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-19 03:00:25 +02:00
*** empty log message ***
This commit is contained in:
Keisuke Nishida
parent
8710eba09b
commit
41f248a84a
14 changed files with 168 additions and 184 deletions
|
|
@ -26,23 +26,6 @@
|
|||
:use-module (ice-9 and-let-star)
|
||||
:export (gscheme))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Macro expander
|
||||
;;;
|
||||
|
||||
(define (expand x)
|
||||
(expand-macro x (current-module)))
|
||||
|
||||
(define (expand-macro x m)
|
||||
(if (pair? x)
|
||||
(let* ((s (car x))
|
||||
(v (and (symbol? s) (module-defined? m s) (module-ref m s))))
|
||||
(if (defmacro? v)
|
||||
(expand-macro (apply (defmacro-transformer v) (cdr x)) m)
|
||||
(cons (expand-macro (car x) m) (expand-macro (cdr x) m))))
|
||||
x))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Translator
|
||||
|
|
@ -111,10 +94,22 @@
|
|||
(_loop ,@(map translate update)))))))
|
||||
(_loop ,@(map translate init))))))
|
||||
(else
|
||||
(let ((prim (and (symbol? head) (symbol-append '@ head))))
|
||||
(if (and prim (ghil-primitive? prim))
|
||||
(cons prim (map translate rest))
|
||||
(cons (translate head) (map translate rest))))))))
|
||||
(let ((e (expand x)))
|
||||
(if (eq? e x)
|
||||
(let ((prim (and (symbol? head) (symbol-append '@ head))))
|
||||
(if (and prim (ghil-primitive? prim))
|
||||
(cons prim (map translate rest))
|
||||
(cons (translate head) (map translate rest))))
|
||||
(translate e)))))))
|
||||
|
||||
(define (expand x)
|
||||
(if (and (symbol? (car x))
|
||||
(module-defined? (current-module) (car x)))
|
||||
(let ((v (module-ref (current-module) (car x))))
|
||||
(if (defmacro? v)
|
||||
(apply (defmacro-transformer v) (cdr x))
|
||||
x))
|
||||
x))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -125,7 +120,6 @@
|
|||
:title "Guile Scheme"
|
||||
:version "0.4"
|
||||
:reader read
|
||||
:expander expand
|
||||
:translator translate
|
||||
:printer write
|
||||
)
|
||||
|
|
|
|||
|
|
@ -136,14 +136,14 @@
|
|||
;; TEST
|
||||
;; (br-if-not L1)
|
||||
;; THEN
|
||||
;; (jump L2)
|
||||
;; (br L2)
|
||||
;; L1: ELSE
|
||||
;; L2:
|
||||
(let ((L1 (make-label)) (L2 (make-label)))
|
||||
(comp-push test)
|
||||
(push-code! (make-<glil-branch> 'br-if-not L1))
|
||||
(comp-tail then)
|
||||
(if (not tail) (push-code! (make-<glil-branch> 'jump L2)))
|
||||
(if (not tail) (push-code! (make-<glil-branch> 'br L2)))
|
||||
(push-code! (make-<glil-label> L1))
|
||||
(comp-tail else)
|
||||
(if (not tail) (push-code! (make-<glil-label> L2)))))
|
||||
|
|
|
|||
|
|
@ -156,7 +156,7 @@
|
|||
(($ <glil-module> op module name)
|
||||
`(,(symbol-append 'module- op) ,module ,name))
|
||||
;; controls
|
||||
(($ <glil-label> label) `(label ,label))
|
||||
(($ <glil-label> label) label)
|
||||
(($ <glil-branch> inst label) `(,inst ,label))
|
||||
(($ <glil-call> inst nargs) `(,inst ,nargs))))
|
||||
|
||||
|
|
@ -168,14 +168,13 @@
|
|||
(define (pprint-glil glil)
|
||||
(let print ((code (unparse glil)) (column 0))
|
||||
(display (make-string column #\space))
|
||||
(case (car code)
|
||||
((@asm)
|
||||
(format #t "(@asm ~A\n" (cadr code))
|
||||
(let ((col (+ column 2)))
|
||||
(let loop ((l (cddr code)))
|
||||
(print (car l) col)
|
||||
(if (null? (cdr l))
|
||||
(display ")")
|
||||
(begin (newline) (loop (cdr l)))))))
|
||||
(else (write code))))
|
||||
(cond ((and (pair? code) (eq? (car code) '@asm))
|
||||
(format #t "(@asm ~A\n" (cadr code))
|
||||
(let ((col (+ column 2)))
|
||||
(let loop ((l (cddr code)))
|
||||
(print (car l) col)
|
||||
(if (null? (cdr l))
|
||||
(display ")")
|
||||
(begin (newline) (loop (cdr l)))))))
|
||||
(else (write code))))
|
||||
(newline))
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
(define-structure (venv parent nexts closure?))
|
||||
(define-structure (vmod id))
|
||||
(define-structure (vlink module name))
|
||||
(define-structure (bytespec nargs nrest nlocs nexts bytes objs))
|
||||
(define-structure (bytespec nargs nrest nlocs nexts bytes objs closure?))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -74,33 +74,17 @@
|
|||
(label-alist '())
|
||||
(object-alist '()))
|
||||
(define (push-code! code)
|
||||
(set! stack (optimizing-push code stack)))
|
||||
(set! stack (cons (code->bytes code) stack)))
|
||||
(define (push-object! x)
|
||||
(cond ((object->code x) => push-code!)
|
||||
(toplevel
|
||||
;; top-level object-dump
|
||||
(cond ((object-assoc x object-alist) =>
|
||||
(lambda (obj+index)
|
||||
(cond ((not (cdr obj+index))
|
||||
(set-cdr! obj+index nlocs)
|
||||
(set! nlocs (+ nlocs 1))))
|
||||
(push-code! `(local-ref ,(cdr obj+index)))))
|
||||
(else
|
||||
(set! object-alist (acons x #f object-alist))
|
||||
(push-code! `(object-dump ,x)))))
|
||||
(toplevel (dump-object! push-code! x))
|
||||
(else
|
||||
;; local object-ref
|
||||
(let ((i (cond ((object-assoc x object-alist) => cdr)
|
||||
(else
|
||||
(let ((i (length object-alist)))
|
||||
(set! object-alist (acons x i object-alist))
|
||||
i)))))
|
||||
(push-code! `(object-ref ,i))))))
|
||||
(define (label-ref key)
|
||||
(assq-ref label-alist key))
|
||||
(define (label-set key)
|
||||
(let ((addr (apply + (map length stack))))
|
||||
(set! label-alist (assq-set! label-alist key addr))))
|
||||
(define (generate-code x)
|
||||
(match x
|
||||
(($ <vm-asm> venv)
|
||||
|
|
@ -108,7 +92,7 @@
|
|||
(if (venv-closure? venv) (push-code! `(make-closure))))
|
||||
|
||||
(($ <glil-void>)
|
||||
(push-code! `(void)))
|
||||
(push-code! '(void)))
|
||||
|
||||
(($ <glil-const> x)
|
||||
(push-object! x))
|
||||
|
|
@ -139,11 +123,14 @@
|
|||
(push-code! '(variable-set))))
|
||||
|
||||
(($ <glil-label> label)
|
||||
(label-set label))
|
||||
(define (byte-length x)
|
||||
(cond ((string? x) (string-length x))
|
||||
(else 3)))
|
||||
(let ((addr (apply + (map byte-length stack))))
|
||||
(set! label-alist (assq-set! label-alist label addr))))
|
||||
|
||||
(($ <glil-branch> inst label)
|
||||
(let ((setter (lambda (addr) (- (label-ref label) addr))))
|
||||
(push-code! (list inst setter))))
|
||||
(set! stack (cons (list inst label) stack)))
|
||||
|
||||
(($ <glil-call> inst nargs)
|
||||
(if (instruction? inst)
|
||||
|
|
@ -158,73 +145,31 @@
|
|||
;;
|
||||
;; main
|
||||
(for-each generate-code body)
|
||||
(if toplevel
|
||||
;; top-level
|
||||
(let ((new '()))
|
||||
(define (push-code! x)
|
||||
(set! new (cons x new)))
|
||||
(do ((stack (reverse! stack) (cdr stack)))
|
||||
((null? stack)
|
||||
(make-dumpcode nlocs nexts (stack->bytes (reverse! new))))
|
||||
(if (eq? (caar stack) 'object-dump)
|
||||
(let ((x (cadar stack)))
|
||||
(dump-object! push-code! x)
|
||||
(cond ((object-assoc x object-alist) =>
|
||||
(lambda (obj+index)
|
||||
(cond ((cdr obj+index) =>
|
||||
(lambda (n)
|
||||
(push-code! '(dup))
|
||||
(push-code! `(local-set ,n)))))))))
|
||||
(push-code! (car stack)))))
|
||||
;; closures
|
||||
(let ((bytes (stack->bytes (reverse! stack)))
|
||||
(objs (map car (reverse! object-alist))))
|
||||
(make-bytespec nargs nrest nlocs nexts bytes objs)))))))
|
||||
(let ((bytes (stack->bytes (reverse! stack) label-alist)))
|
||||
(if toplevel
|
||||
(make-dumpcode nlocs nexts bytes)
|
||||
(let ((objs (map car (reverse! object-alist))))
|
||||
(make-bytespec nargs nrest nlocs nexts bytes objs
|
||||
(venv-closure? venv)))))))))
|
||||
|
||||
(define (object-assoc x alist)
|
||||
(if (vlink? x) (assoc x alist) (assq x alist)))
|
||||
|
||||
(define (stack->bytes stack)
|
||||
(define (stack->bytes stack label-alist)
|
||||
(let loop ((result '()) (stack stack) (addr 0))
|
||||
(if (null? stack)
|
||||
(apply string-append (reverse! result))
|
||||
(let* ((orig (car stack))
|
||||
(addr (+ addr (length orig)))
|
||||
(code (if (and (pair? (cdr orig)) (procedure? (cadr orig)))
|
||||
`(,(car orig) ,((cadr orig) addr))
|
||||
orig)))
|
||||
(loop (cons (code->bytes code) result) (cdr stack) addr)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Bytecode optimization
|
||||
;;;
|
||||
|
||||
(define *optimization-table*
|
||||
'((not (not . not-not)
|
||||
(eq? . not-eq?)
|
||||
(null? . not-null?)
|
||||
(not-not . not)
|
||||
(not-eq? . eq?)
|
||||
(not-null? . null?))
|
||||
(br-if (not . br-if-not)
|
||||
(eq? . br-if-eq)
|
||||
(null? . br-if-null)
|
||||
(not-not . br-if)
|
||||
(not-eq? . br-if-not-eq)
|
||||
(not-null? . br-if-not-null))
|
||||
(br-if-not (not . br-if)
|
||||
(eq? . br-if-not-eq)
|
||||
(null? . br-if-not-null)
|
||||
(not-not . br-if-not)
|
||||
(not-eq? . br-if-eq)
|
||||
(not-null? . br-if-null))))
|
||||
|
||||
(define (optimizing-push code stack)
|
||||
(let ((alist (assq-ref *optimization-table* (car code))))
|
||||
(cond ((and alist (pair? stack) (assq-ref alist (caar stack))) =>
|
||||
(lambda (inst) (cons (cons inst (cdr code)) (cdr stack))))
|
||||
(else (cons (code-pack code) stack)))))
|
||||
(let ((bytes (car stack)))
|
||||
(if (pair? bytes)
|
||||
(let* ((offset (- (assq-ref label-alist (cadr bytes))
|
||||
(+ addr 3)))
|
||||
(n (if (< offset 0) (+ offset 65536) offset)))
|
||||
(set! bytes (code->bytes (list (car bytes)
|
||||
(quotient n 256)
|
||||
(modulo n 256))))))
|
||||
(loop (cons bytes result)
|
||||
(cdr stack)
|
||||
(+ addr (string-length bytes)))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -239,7 +184,7 @@
|
|||
((object->code x) => push-code!)
|
||||
((bytespec? x)
|
||||
(match x
|
||||
(($ bytespec nargs nrest nlocs nexts bytes objs)
|
||||
(($ bytespec nargs nrest nlocs nexts bytes objs closure?)
|
||||
;; dump parameters
|
||||
(cond
|
||||
((and (< nargs 4) (< nlocs 8) (< nexts 4))
|
||||
|
|
@ -264,7 +209,7 @@
|
|||
;; dump bytecode
|
||||
(push-code! `(load-program ,bytes)))))
|
||||
((vlink? x)
|
||||
(dump! (vlink-module x))
|
||||
;;; (dump! (vlink-module x)) ;; FIXME: no module support now
|
||||
(dump! (vlink-name x))
|
||||
(push-code! `(link)))
|
||||
((vmod? x)
|
||||
|
|
|
|||
|
|
@ -36,11 +36,6 @@
|
|||
(cond ((< n 10)
|
||||
(let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
|
||||
(if (instruction? abbrev) (list abbrev) code)))
|
||||
((> n 255)
|
||||
(let ((double (string->symbol (format #f "~A*2" inst))))
|
||||
(if (instruction? double)
|
||||
(list double (quotient n 256) (modulo n 256))
|
||||
(apply error "Index out of range:" code))))
|
||||
(else code)))
|
||||
(else code)))
|
||||
|
||||
|
|
@ -91,7 +86,8 @@
|
|||
(else #f)))
|
||||
|
||||
(define (code->bytes code)
|
||||
(let* ((inst (car code))
|
||||
(let* ((code (code-pack code))
|
||||
(inst (car code))
|
||||
(rest (cdr code))
|
||||
(head (make-string 1 (integer->char (instruction->opcode inst))))
|
||||
(len (instruction-length inst)))
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@
|
|||
(nlocs (caddr arity))
|
||||
(nexts (cadddr arity))
|
||||
(bytes (program-bytecode prog))
|
||||
(objs (program-objects prog)))
|
||||
(objs (program-objects prog))
|
||||
(exts (program-external prog)))
|
||||
;; Disassemble this bytecode
|
||||
(format #t "Disassembly of ~A:\n\n" prog)
|
||||
(format #t "nargs = ~A nrest = ~A nlocs = ~A nexts = ~A\n\n"
|
||||
|
|
@ -53,6 +54,8 @@
|
|||
(disassemble-bytecode bytes objs)
|
||||
(if (> (vector-length objs) 0)
|
||||
(disassemble-objects objs))
|
||||
(if (pair? exts)
|
||||
(disassemble-externals exts))
|
||||
;; Disassemble other bytecode in it
|
||||
(for-each
|
||||
(lambda (x)
|
||||
|
|
@ -89,6 +92,15 @@
|
|||
(let ((info (object->string (vector-ref objs n))))
|
||||
(print-info n info #f)))))
|
||||
|
||||
(define (disassemble-externals exts)
|
||||
(display "Externals:\n\n")
|
||||
(let ((len (length exts)))
|
||||
(do ((n 0 (1+ n))
|
||||
(l exts (cdr l)))
|
||||
((null? l) (newline))
|
||||
(let ((info (object->string (car l))))
|
||||
(print-info n info #f)))))
|
||||
|
||||
(define (disassemble-meta meta)
|
||||
(display "Meta info:\n\n")
|
||||
(for-each (lambda (data)
|
||||
|
|
@ -98,11 +110,12 @@
|
|||
|
||||
(define (original-value addr code objs)
|
||||
(define (branch-code? code)
|
||||
(string-match "^(br|jump)" (symbol->string (car code))))
|
||||
(string-match "^br" (symbol->string (car code))))
|
||||
(let ((code (code-unpack code)))
|
||||
(cond ((code->object code) => object->string)
|
||||
((branch-code? code)
|
||||
(format #f "-> ~A" (+ addr (cadr code) 2)))
|
||||
(let ((offset (+ (* (cadr code) 256) (caddr code))))
|
||||
(format #f "-> ~A" (+ addr offset 3))))
|
||||
(else
|
||||
(let ((inst (car code)) (args (cdr code)))
|
||||
(case inst
|
||||
|
|
|
|||
|
|
@ -20,8 +20,8 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system vm load)
|
||||
:use-module (system vm core)
|
||||
:autoload (system base language) (compile-file-in lookup-language)
|
||||
:use-module (system vm core)
|
||||
:use-module (ice-9 regex)
|
||||
:export (load/compile))
|
||||
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (system vm trace)
|
||||
:use-syntax (system base syntax)
|
||||
:use-module (system vm core)
|
||||
:use-module (system vm frame)
|
||||
:use-module (ice-9 format)
|
||||
|
|
@ -49,7 +50,7 @@
|
|||
(case (car opts)
|
||||
((:s) (format #t "~20S" (vm-fetch-stack vm)))
|
||||
((:v) (format #t "~20S" (frame-variables frame)))
|
||||
((:e) (format #t "~20S" (program-external (frame-program frame))))))))
|
||||
((:e) (format #t "~20A" (object->string (frame-external-link frame))))))))
|
||||
|
||||
(define (trace-apply vm)
|
||||
(if (vm-option vm 'trace-first)
|
||||
|
|
|
|||
35
src/vm.c
35
src/vm.c
|
|
@ -64,10 +64,11 @@ make_vm_heap_frame (SCM *fp)
|
|||
{
|
||||
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;
|
||||
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_vm_heap_frame, p);
|
||||
}
|
||||
|
||||
|
|
@ -77,7 +78,8 @@ vm_heap_frame_mark (SCM 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;
|
||||
scm_gc_mark (p->dynamic_link);
|
||||
return p->external_link;
|
||||
}
|
||||
|
||||
/* Scheme interface */
|
||||
|
|
@ -146,6 +148,23 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
|
||||
(SCM frame),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_frame_external_link
|
||||
{
|
||||
struct scm_vm_heap_frame *p;
|
||||
|
||||
SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
|
||||
p = SCM_VM_HEAP_FRAME_DATA (frame);
|
||||
|
||||
if (SCM_UNBNDP (p->external_link))
|
||||
p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (p->fp);
|
||||
|
||||
return p->external_link;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
/*
|
||||
* VM Continuation
|
||||
|
|
@ -213,7 +232,7 @@ vm_cont_free (SCM obj)
|
|||
* VM Internal functions
|
||||
*/
|
||||
|
||||
SCM_SYMBOL (sym_vm_engine, "vm-engine");
|
||||
SCM_SYMBOL (sym_vm_run, "vm-run");
|
||||
SCM_SYMBOL (sym_vm_error, "vm-error");
|
||||
|
||||
static scm_byte_t *
|
||||
|
|
@ -307,7 +326,7 @@ vm_mark (SCM obj)
|
|||
for (; sp >= upper; sp--)
|
||||
if (SCM_NIMP (*sp))
|
||||
scm_gc_mark (*sp);
|
||||
fp = SCM_VM_STACK_ADDRESS (*sp); /* dynamic link */
|
||||
fp = SCM_VM_STACK_ADDRESS (sp[-1]); /* dynamic link */
|
||||
/* Mark frame variables + program */
|
||||
for (sp -= 2; sp >= lower; sp--)
|
||||
if (SCM_NIMP (*sp))
|
||||
|
|
@ -337,7 +356,7 @@ scm_vm_apply (SCM vm, SCM program, SCM args)
|
|||
#define FUNC_NAME "scm_vm_apply"
|
||||
{
|
||||
SCM_VALIDATE_PROGRAM (1, program);
|
||||
return vm_engine (vm, program, args);
|
||||
return vm_run (vm, program, args);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
14
src/vm.h
14
src/vm.h
|
|
@ -61,10 +61,11 @@
|
|||
*/
|
||||
|
||||
/*
|
||||
| | <- fp + bp->nargs + bp->nlocs + 2
|
||||
| | <- fp + bp->nargs + bp->nlocs + 3
|
||||
+------------------+ = SCM_VM_FRAME_UPPER_ADDRESS (fp)
|
||||
| Return address |
|
||||
| Dynamic link |
|
||||
| Return address | <- fp + bp->nargs + bp->nlocs
|
||||
| External link | <- fp + bp->nargs + bp->nlocs
|
||||
| Local varialbe 1 | = SCM_VM_FRAME_DATA_ADDRESS (fp)
|
||||
| Local variable 0 | <- fp + bp->nargs
|
||||
| Argument 1 |
|
||||
|
|
@ -74,15 +75,16 @@
|
|||
| |
|
||||
*/
|
||||
|
||||
#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_UPPER_ADDRESS(fp) \
|
||||
(SCM_VM_FRAME_DATA_ADDRESS (fp) + 2)
|
||||
(SCM_VM_FRAME_DATA_ADDRESS (fp) + 3)
|
||||
#define SCM_VM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
|
||||
|
||||
#define SCM_VM_FRAME_RETURN_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)[0]
|
||||
#define SCM_VM_FRAME_EXTERNAL_LINK(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[0]
|
||||
#define SCM_VM_FRAME_VARIABLE(fp,i) fp[i]
|
||||
#define SCM_VM_FRAME_PROGRAM(fp) fp[-1]
|
||||
|
||||
|
|
@ -95,6 +97,7 @@ struct scm_vm_heap_frame {
|
|||
SCM program;
|
||||
SCM variables;
|
||||
SCM dynamic_link;
|
||||
SCM external_link;
|
||||
};
|
||||
|
||||
extern scm_bits_t scm_tc16_vm_heap_frame;
|
||||
|
|
@ -106,6 +109,7 @@ extern scm_bits_t scm_tc16_vm_heap_frame;
|
|||
#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
|
||||
#define SCM_VM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->external_link
|
||||
|
||||
/*
|
||||
* VM
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@
|
|||
#include "vm_engine.h"
|
||||
|
||||
static SCM
|
||||
vm_engine (SCM vm, SCM program, SCM args)
|
||||
vm_run (SCM vm, SCM program, SCM args)
|
||||
#define FUNC_NAME "vm-engine"
|
||||
{
|
||||
/* VM registers */
|
||||
|
|
@ -55,7 +55,7 @@ vm_engine (SCM vm, SCM program, SCM args)
|
|||
/* Cache variables */
|
||||
struct scm_vm *vp = SCM_VM_DATA (vm); /* VM data pointer */
|
||||
struct scm_program *bp = NULL; /* program base pointer */
|
||||
SCM external; /* external environment */
|
||||
SCM external = SCM_EOL; /* external environment */
|
||||
SCM *objects = NULL; /* constant objects */
|
||||
SCM *stack_base = vp->stack_base; /* stack base address */
|
||||
SCM *stack_limit = vp->stack_limit; /* stack limit address */
|
||||
|
|
@ -161,7 +161,7 @@ vm_engine (SCM vm, SCM program, SCM args)
|
|||
vm_error:
|
||||
SYNC_ALL ();
|
||||
scm_ithrow (sym_vm_error,
|
||||
SCM_LIST4 (sym_vm_engine, err_msg, err_args,
|
||||
SCM_LIST4 (sym_vm_run, err_msg, err_args,
|
||||
scm_vm_current_frame (vm)),
|
||||
1);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -132,8 +132,17 @@
|
|||
#define CACHE_PROGRAM() \
|
||||
{ \
|
||||
bp = SCM_PROGRAM_DATA (program); \
|
||||
objects = SCM_VELTS (bp->objs); \
|
||||
external = bp->external; \
|
||||
objects = SCM_VELTS (bp->objs); \
|
||||
}
|
||||
|
||||
#define CACHE_EXTERNAL() \
|
||||
{ \
|
||||
external = fp[bp->nargs + bp->nlocs]; \
|
||||
}
|
||||
|
||||
#define SYNC_EXTERNAL() \
|
||||
{ \
|
||||
fp[bp->nargs + bp->nlocs] = external; \
|
||||
}
|
||||
|
||||
#define SYNC_BEFORE_GC() \
|
||||
|
|
@ -280,17 +289,18 @@ do { \
|
|||
SCM dl = SCM_VM_MAKE_STACK_ADDRESS (fp); \
|
||||
ip = bp->base; \
|
||||
fp = sp - bp->nargs + 1; \
|
||||
sp = sp + bp->nlocs + 2; \
|
||||
sp = sp + bp->nlocs + 3; \
|
||||
CHECK_OVERFLOW (); \
|
||||
sp[0] = dl; \
|
||||
sp[-1] = ra; \
|
||||
sp[0] = ra; \
|
||||
sp[-1] = dl; \
|
||||
sp[-2] = bp->external; \
|
||||
}
|
||||
|
||||
#define FREE_FRAME() \
|
||||
{ \
|
||||
SCM *new_sp = fp - 2; \
|
||||
sp = fp + bp->nargs + bp->nlocs; \
|
||||
ip = SCM_VM_BYTE_ADDRESS (sp[0]); \
|
||||
ip = SCM_VM_BYTE_ADDRESS (sp[2]); \
|
||||
fp = SCM_VM_STACK_ADDRESS (sp[1]); \
|
||||
sp = new_sp; \
|
||||
}
|
||||
|
|
|
|||
|
|
@ -159,25 +159,21 @@ VM_DEFINE_LOADER (load_program, "load-program")
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
|
||||
VM_DEFINE_INSTRUCTION (link, "link", 0, 1, 1)
|
||||
{
|
||||
if (!SCM_FALSEP (sp[-1]))
|
||||
{
|
||||
sp[-1] = scm_c_env_vcell (sp[-1], sp[0], 1);
|
||||
sp--;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Temporary hack that supports the current module system */
|
||||
SCM mod = scm_current_module ();
|
||||
SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
|
||||
*sp, SCM_BOOL_F);
|
||||
if (SCM_FALSEP (var))
|
||||
/* Create a new variable if not defined yet */
|
||||
var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
|
||||
*sp, SCM_BOOL_T);
|
||||
*--sp = SCM_VARVCELL (var);
|
||||
}
|
||||
#if 0
|
||||
sp[-1] = scm_c_env_vcell (sp[-1], sp[0], 1);
|
||||
sp--;
|
||||
#endif
|
||||
/* Temporary hack that supports the current module system */
|
||||
SCM mod = scm_current_module ();
|
||||
SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
|
||||
*sp, SCM_BOOL_F);
|
||||
if (SCM_FALSEP (var))
|
||||
/* Create a new variable if not defined yet */
|
||||
var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
|
||||
*sp, SCM_BOOL_T);
|
||||
*sp = SCM_VARVCELL (var);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -223,49 +223,53 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
|
|||
|
||||
#define BR(p) \
|
||||
{ \
|
||||
signed char offset = FETCH (); \
|
||||
int h = FETCH (); \
|
||||
int l = FETCH (); \
|
||||
signed short offset = (h << 8) + l; \
|
||||
if (p) \
|
||||
ip += offset; \
|
||||
DROP (); \
|
||||
NEXT; \
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if, "br-if", 1, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
|
||||
{
|
||||
int h = FETCH ();
|
||||
int l = FETCH ();
|
||||
ip += (signed short) (h << 8) + l;
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0)
|
||||
{
|
||||
BR (!SCM_FALSEP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0)
|
||||
{
|
||||
BR (SCM_FALSEP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0)
|
||||
{
|
||||
BR (SCM_EQ_P (sp[0], sp--[1]));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0)
|
||||
{
|
||||
BR (!SCM_EQ_P (sp[0], sp--[1]));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0)
|
||||
{
|
||||
BR (SCM_NULLP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
|
||||
{
|
||||
BR (!SCM_NULLP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (jump, "jump", 1, 0, 0)
|
||||
{
|
||||
ip += (signed char) FETCH ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Subprogram call
|
||||
|
|
@ -305,8 +309,10 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
|
|||
LOCAL_SET (i, SCM_UNDEFINED);
|
||||
|
||||
/* Create external variables */
|
||||
CACHE_EXTERNAL ();
|
||||
for (i = 0; i < bp->nexts; i++)
|
||||
CONS (external, SCM_UNDEFINED, external);
|
||||
SYNC_EXTERNAL ();
|
||||
|
||||
ENTER_HOOK ();
|
||||
APPLY_HOOK ();
|
||||
|
|
@ -454,6 +460,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
|
|||
/* Restore the last program */
|
||||
program = SCM_VM_FRAME_PROGRAM (fp);
|
||||
CACHE_PROGRAM ();
|
||||
CACHE_EXTERNAL ();
|
||||
PUSH (ret);
|
||||
NEXT;
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue