summaryrefslogtreecommitdiff
path: root/module/system/vm/core.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/core.scm')
-rw-r--r--module/system/vm/core.scm68
1 files changed, 23 insertions, 45 deletions
diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm
index 87810c914..a5679d08b 100644
--- a/module/system/vm/core.scm
+++ b/module/system/vm/core.scm
@@ -21,6 +21,7 @@
(define-module (system vm core))
+
;;;
;;; Core procedures
;;;
@@ -32,60 +33,37 @@
(hash-fold (lambda (k v d) (cons k d)) '()
(module-obarray (current-module)))))
+
;;;
-;;; Dumpcode interface
+;;; Loader
;;;
-(export make-dumpcode dumpcode? dumpcode-version
- dumpcode-nlocs dumpcode-nexts dumpcode-bytecode
- load-dumpcode save-dumpcode)
+(define-public (vm-load vm objcode)
+ (vm (objcode->program objcode)))
-(define *dumpcode-cookie* (string-append "\0GBC-" (vm-version)))
+(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file))))
-(define (make-dumpcode nlocs nexts bytes)
- (string-append *dumpcode-cookie*
- (integer->bytes nlocs)
- (integer->bytes nexts)
- bytes))
-
-(define (dumpcode? x)
- (and (string? x)
- (> (string-length x) 10)
- (string=? (substring x 1 4) "GBC")))
-
-(define (dumpcode-version x)
- (substring x 5 8))
-
-(define (dumpcode-nlocs x)
- (bytes->integer x 8))
-
-(define (dumpcode-nexts x)
- (bytes->integer x 9))
-
-(define (dumpcode-bytecode x)
- (substring x 10))
-
-(define (load-dumpcode file)
- (let ((bytes (make-uniform-vector (stat:size (stat file)) #\a)))
- (call-with-input-file file
- (lambda (p) (uniform-vector-read! bytes p)))
- bytes))
-
-(define (save-dumpcode dump file)
- (call-with-output-file file
- (lambda (out) (uniform-vector-write dump out))))
+
+;;;
+;;; Frame interface
+;;;
-(define (integer->bytes n)
- (string (integer->char n)))
+(define-public (frame->call frame)
+ (let* ((prog (frame-program frame))
+ (nargs (car (program-arity prog))))
+ (do ((i 0 (1+ i))
+ (l (vector->list (frame-variables frame)) (cdr l))
+ (r '() (cons (car l) r)))
+ ((= i nargs) (cons (program-name prog) (reverse! r))))))
-(define (bytes->integer bytes start)
- (char->integer (string-ref bytes start)))
+(define (program-name x)
+ (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
+ (module-obarray (current-module))))
+
;;;
;;; Statistics interface
;;;
-(export vms:time vms:clock)
-
-(define (vms:time stat) (vector-ref stat 0))
-(define (vms:clock stat) (vector-ref stat 1))
+(define-public (vms:time stat) (vector-ref stat 0))
+(define-public (vms:clock stat) (vector-ref stat 1))