diff --git a/module/language/gscheme/spec.scm b/module/language/gscheme/spec.scm index 5cbbc6409..471120bb1 100644 --- a/module/language/gscheme/spec.scm +++ b/module/language/gscheme/spec.scm @@ -21,6 +21,8 @@ (define-module (language gscheme spec) :use-module (system base language) + :use-module (system il ghil) + :use-module (language r5rs expand) :use-module (ice-9 match) :export (gscheme)) @@ -29,37 +31,33 @@ ;;; Macro expander ;;; -(define (expand x) +(define expand-syntax expand) + +(define (expand-macro x m) (if (pair? x) (let* ((s (car x)) - (m (current-module)) (v (and (symbol? s) (module-defined? m s) (module-ref m s)))) (if (defmacro? v) - (expand (apply (defmacro-transformer v) (cdr x))) - (cons (expand (car x)) (expand (cdr x))))) + (expand-macro (apply (defmacro-transformer v) (cdr x)) m) + (cons (expand-macro (car x) m) (expand-macro (cdr x) m)))) x)) +(define (expand x) + (expand-syntax (expand-macro x (current-module)))) + ;;; ;;; Translator ;;; -(define *primitive-procedure-list* - '(void car cdr cons + - < >)) - (define (translate x) (if (pair? x) (translate-pair x) x)) (define (translate-pair x) (let ((name (car x)) (args (cdr x))) (case name ((quote) (cons '@quote args)) - ((set! if and or begin) + ((define set! if and or begin) (cons (symbol-append '@ name) (map translate args))) - ((define) - (if (pair? (car args)) - `(@define ,(caar args) - (@lambda ,(cdar args) ,@(map translate (cdr args)))) - `(@define ,(car args) ,@(map translate (cdr args))))) ((let let* letrec) (match x (('let (? symbol? f) ((s v) ...) body ...) @@ -73,9 +71,10 @@ ((lambda) (cons* '@lambda (car args) (map translate (cdr args)))) (else - (if (memq name *primitive-procedure-list*) - (cons (symbol-append '@ name) (map translate args)) - (cons (translate name) (map translate args))))))) + (let ((prim (symbol-append '@ name))) + (if (ghil-primitive? prim) + (cons prim (map translate args)) + (cons (translate name) (map translate args)))))))) ;;; diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 42e306e44..835e7a522 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -95,7 +95,7 @@ (call-with-output-file (object-file-name file) (lambda (out) (uniform-vector-write bytes out))))) -(define (load-file-in file env lang) +(define (load-file-in file env lang . opts) (let ((compiled (object-file-name file))) (if (or (not (file-exists? compiled)) (> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 68b3f42d5..a04ee00cb 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -55,8 +55,8 @@ ;;; (define *ia-void* (make-)) -(define *ia-drop* (make- 'drop)) -(define *ia-return* (make- 'return)) +(define *ia-drop* (make- 'drop 0)) +(define *ia-return* (make- 'return 0)) (define (make-label) (gensym ":L")) @@ -147,6 +147,14 @@ (($ vars rest body) (return-code! (codegen tree))) + (($ inst args) + ;; ARGS... + ;; (INST NARGS) + (for-each comp-push args) + (push-code! (make- inst (length args))) + (if drop (push-code! *ia-drop*)) + (if tail (push-code! *ia-return*))) + (($ proc args) ;; ARGS... ;; PROC @@ -155,15 +163,7 @@ (comp-push proc) (let ((inst (if tail 'tail-call 'call))) (push-code! (make- inst (length args)))) - (if drop (push-code! *ia-drop*))) - - (($ inst args) - ;; ARGS... - ;; (INST) - (for-each comp-push args) - (push-code! (make- inst)) - (if drop (push-code! *ia-drop*)) - (if tail (push-code! *ia-return*))))) + (if drop (push-code! *ia-drop*))))) ;; ;; main (match ghil diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index 57e78d327..91c4ad505 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -26,6 +26,7 @@ :use-module (ice-9 regex) :export (parse-ghil + ghil-primitive? make- ? make- ? -1 make- ? -1 -2 @@ -56,6 +57,26 @@ (define-structure ( proc args)) (define-structure ( inst args)) + +;;; +;;; Procedures +;;; + +(define *core-primitives* + '(@void @quote @define @set! @if @begin @let @letrec @lambda)) + +(define *macro-module* (resolve-module '(system il macros))) + +(define (ghil-primitive-macro? x) + (module-defined? *macro-module* x)) + +(define (ghil-macro-expander x) + (module-ref *macro-module* x)) + +(define (ghil-primitive? x) + (or (memq x *core-primitives*) + (ghil-primitive-macro? x))) + ;;; ;;; Variables @@ -146,13 +167,11 @@ (define (map-parse x e) (map (lambda (x) (parse x e)) x)) -(define *macros* (resolve-module '(system il macros))) - (define (parse-pair x e) (let ((head (car x)) (tail (cdr x))) (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@)) - (if (module-defined? *macros* head) - (parse (apply (module-ref *macros* head) tail) e) + (if (ghil-primitive-macro? head) + (parse (apply (ghil-macro-expander head) tail) e) (parse-primitive head tail e)) (make- (parse head e) (map-parse tail e))))) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index f9eaba9b0..c54509d12 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -40,7 +40,6 @@ make- ? -1 make- ? -1 -2 make- ? -1 -2 - make- ? -1 )) ;; Meta operations @@ -60,8 +59,7 @@ ;; Controls (define-structure ( label)) (define-structure ( inst label)) -(define-structure ( inst n)) -(define-structure ( inst)) +(define-structure ( inst nargs)) ;;; @@ -160,8 +158,7 @@ ;; controls (($ label) `(label ,label)) (($ inst label) `(,inst ,label)) - (($ inst n) `(,inst ,n)) - (($ inst) `(,inst)))) + (($ inst nargs) `(,inst ,nargs)))) ;;; diff --git a/module/system/il/macros.scm b/module/system/il/macros.scm index 2897f3e8e..c3cc4c4ee 100644 --- a/module/system/il/macros.scm +++ b/module/system/il/macros.scm @@ -25,13 +25,6 @@ (define (make-label) (gensym ":L")) (define (make-sym) (gensym "_")) -;;; -;;; Module macros -;;; - -(define (@import identifier) - `((@ System::Base::module::do-import) (@quote ,identifier))) - ;;; ;;; Syntax @@ -155,12 +148,12 @@ ((x y) `(@@ div ,x ,y)) ((x y . rest) `(@@ div ,x (@* ,y ,@rest))))) -;;; abs -;;; -;;; quotient +(define (@abs x) `(@if (@< x 0) (@- x) x)) + +(define (@quotient x y) `(@@ quotient ,x ,y)) (define (@remainder x y) `(@@ remainder ,x ,y)) -;;; modulo -;;; +(define (@modulo x y) `(@@ modulo ,x ,y)) + ;;; gcd ;;; lcm ;;; @@ -337,34 +330,14 @@ ;; (define (@apply proc . args) ...) -(define (@map f ls . more) - (if (null? more) - `(@let ((f ,f)) - (@let map1 ((ls ,ls)) - (@if (@null? ls) - '() - (@cons (f (car ls)) (map1 (cdr ls)))))) - `(@let ((f ,f)) - (@let map-more ((ls ,ls) (more ,more)) - (@if (@null? ls) - '() - (@cons (@apply f (car ls) (map car more)) - (map-more (cdr ls) (map cdr more)))))))) +;;; map +;;; for-each -(define @for-each - (match-lambda* - ((f l) - (do ((ls ls (cdr ls)) (more more (map cdr more))) - ((null? ls)) - (apply f (car ls) (map car more)))) - ((f . args) - `(@apply (@~ system:il:base:for-each) args)))) +;;; (define (@force promise) `(@@ force promise)) -(define (@force promise) `(@@ force promise)) +;;; (define (@call-with-current-continuation proc) `(@@ call/cc proc)) -(define (@call-with-current-continuation proc) `(@@ call/cc proc)) - -(define @call/cc @call-with-current-continuation) +;;; (define @call/cc @call-with-current-continuation) ;;; values ;;; call-with-values diff --git a/module/system/repl/command.gsm b/module/system/repl/command.gsm deleted file mode 100644 index 97b2e62c6..000000000 --- a/module/system/repl/command.gsm +++ /dev/null @@ -1,488 +0,0 @@ -;;; REPL commands - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define (puts x) (display x) (newline)) - -(define (user-error msg . args) - (throw 'user-error #f msg args #f)) - - -;;; -;;; Meta command -;;; - -(define *command-table* - '((help (help h) (apropos a) (describe d) (option o) (quit q)) - (module (module m) (use u) (import i) (load l) (binding b) (lsmod lm)) - (package (package p) (lspkg lp) (autopackage) (globals g)) - (language (language L)) - (compile (compile c) (compile-file cc) - (disassemble x) (disassemble-file xx)) - (profile (time t) (profile pr)) - (debug (backtrace bt) (debugger db) (trace tr) (step st)) - (system (statistics stat) (gc)))) - -(define (group-name g) (car g)) -(define (group-commands g) (cdr g)) - -(define *command-module* (current-module)) -(define (command-name c) (car c)) -(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c))) -(define (command-procedure c) (module-ref *command-module* (command-name c))) -(define (command-doc c) (procedure-documentation (command-procedure c))) - -(define (command-usage c) - (let ((doc (command-doc c))) - (substring doc 0 (string-index doc #\newline)))) - -(define (command-summary c) - (let* ((doc (command-doc c)) - (start (1+ (string-index doc #\newline)))) - (cond ((string-index doc #\newline start) - => (lambda (end) (substring doc start end))) - (else (substring doc start))))) - -(define (lookup-group name) - (assq name *command-table*)) - -(define (lookup-command key) - (let loop ((groups *command-table*) (commands '())) - (cond ((and (null? groups) (null? commands)) #f) - ((null? commands) - (loop (cdr groups) (cdar groups))) - ((memq key (car commands)) (car commands)) - (else (loop groups (cdr commands)))))) - -(define (display-group group . opts) - (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group)) - (for-each (lambda (c) - (display-summary (command-usage c) - (command-abbrev c) - (command-summary c))) - (group-commands group)) - (newline)) - -(define (display-command command) - (display "Usage: ") - (display (command-doc command)) - (newline)) - -(define (display-summary usage abbrev summary) - (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) ""))) - (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary))) - -(define (meta-command repl line) - (let ((input (call-with-input-string (string-append "(" line ")") read))) - (if (not (null? input)) - (do ((key (car input)) - (args (cdr input) (cdr args)) - (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts))) - ((or (null? args) - (not (symbol? (car args))) - (not (eq? (string-ref (symbol->string (car args)) 0) #\-))) - (let ((c (lookup-command key))) - (if c - (cond ((memq :h opts) (display-command c)) - (else (apply (command-procedure c) - repl (append! args opts)))) - (user-error "Unknown meta command: ~A" key)))))))) - - -;;; -;;; Help commands -;;; - -(define (help repl . args) - "help [GROUP] -Show help messages. -The optional argument can be either one of command groups or -command names. Without argument, a list of help commands and -all command groups are displayed, as you have already seen :)" - (match args - (() - (display-group (lookup-group 'help)) - (display "Command Groups:\n\n") - (display-summary "help all" #f "List all commands") - (for-each (lambda (g) - (let* ((name (symbol->string (group-name g))) - (usage (string-append "help " name)) - (header (string-append "List " name " commands"))) - (display-summary usage #f header))) - (cdr *command-table*)) - (newline) - (display "Enter `,COMMAND -h' to display documentation of each command.") - (newline)) - (('all) - (for-each display-group *command-table*)) - ((? lookup-group group) - (display-group (lookup-group group))) - (else (user-error "Unknown command group: ~A" (car args))))) - -(define guile-apropos apropos) -(define (apropos repl regexp) - "apropos [options] REGEXP -Find bindings/modules/packages." - (guile-apropos (object->string regexp display))) - -(define (describe repl obj) - "describe OBJ -Show description/documentation." - (display "Not implemented yet\n")) - -(define (option repl . args) - "option [KEY [VALUE]] -List/show/set options." - (display "Not implemented yet\n")) - -(define (quit repl) - "quit -Quit this session." - (throw 'quit)) - - -;;; -;;; Module commands -;;; - -(define (module repl . args) - "module [MODULE] -Change modules / Show current module." - (match args - (() (puts (binding repl.module))))) - -(define (use repl . args) - "use [MODULE ...] -Use modules." - (define (use name) - (let ((mod (resolve-interface name))) - (if mod - (module-use! repl.module mod) - (user-error "No such module: ~A" name)))) - (if (null? args) - (for-each puts (map module-name - (cons repl.module (module-uses repl.module)))) - (for-each (lambda (name) - (cond - ((pair? name) (use name)) - ((symbol? name) - (cond ((find-one-module (symbol->string name)) => use))) - (else (user-error "Invalid module name: ~A" name)))) - args))) - -(define (import repl . args) - "import [MODULE ...] -Import modules / List those imported." - (define (use name) - (let ((mod (resolve-interface name))) - (if mod - (module-use! repl.module mod) - (user-error "No such module: ~A" name)))) - (if (null? args) - (for-each puts (map module-name - (cons repl.module (module-uses repl.module)))) - (for-each (lambda (name) - (cond - ((pair? name) (use name)) - ((symbol? name) - (and-let* ((m (find-one-module (symbol->string name)))) - (puts m) (use m))) - (else (user-error "Invalid module name: ~A" name)))) - args))) - -(define (load repl file . opts) - "load [options] FILE -Load a file in the current module." - (apply repl-load-file repl (->string file) opts)) - -(define (binding repl . opts) - "binding [-a] -List current bindings." - (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.module)) - -(define (lsmod repl . args) - "lsmod -." - (define (use name) - (set! repl.module (resolve-module name)) - (module-use! repl.module repl.value-history)) - (if (null? args) - (use '(guile-user)) - (let ((name (car args))) - (cond - ((pair? name) (use name)) - ((symbol? name) - (and-let* ((m (find-one-module (symbol->string name)))) - (puts m) (use m))) - (else (user-error "Invalid module name: ~A" name)))))) - - -;;; -;;; Package commands -;;; - -(define (package repl) - "package [PACKAGE] -List available packages/modules." - (for-each puts (find-module ""))) - -(define (lspkg repl) - "lspkg -List available packages/modules." - (for-each puts (find-module ""))) - -(define (autopackage repl) - "autopackage -List available packages/modules." - (for-each puts (find-module ""))) - -(define (globals repl) - "globals -List all global variables." - (global-fold (lambda (s v d) (format #t "~A\t~S\n" s v)) #f)) - - -;;; -;;; Language commands -;;; - -(define (language repl name) - "language LANGUAGE -Change languages." - (set! repl.language (lookup-language name)) - (repl-welcome repl)) - - -;;; -;;; Compile commands -;;; - -(define (compile repl form . opts) - "compile [options] FORM -Generate compiled code. - - -e Stop after expanding syntax/macro - -t Stop after translating into GHIL - -c Stop after generating GLIL - -l Stop before linking - -o Compile into bytecode - - -O Enable optimization - -D Add debug information" - (let ((x (apply repl-compile repl form opts))) - (cond ((null? opts) - (disassemble-program x)) - ((memq :l opts) - (disassemble-bytecode x)) - ((memq :c opts) - (pprint-glil x)) - (else - (puts x))))) - -(define (compile-file repl file . opts) - "compile-file [options] FILE -Compile a file." - (apply repl-compile-file repl (->string file) opts)) - -(define (disassemble repl prog) - "disassemble PROGRAM -Disassemble a program." - (disassemble-program (repl.vm (repl-compile repl prog)))) - -(define (disassemble-file repl file) - "disassemble-file FILE -Disassemble a file." - (disassemble-bytecode (load-file-in (->string file) - repl.module - repl.language))) - -(define (->string x) - (object->string x display)) - - -;;; -;;; Profile commands -;;; - -(define (profile repl form . opts) - "profile FORM -Profile execution." - (apply vm-profile repl.vm (repl-compile repl form) opts)) - - -;;; -;;; Debug commands -;;; - -(define guile-backtrace backtrace) -(define (backtrace repl) - "backtrace -Show backtrace (if any)." - (guile-backtrace)) - -(define (debugger repl) - "debugger -Start debugger." - (debug)) - -(define (trace repl form . opts) - "trace [-a] FORM -Trace execution." - (apply vm-trace repl.vm (repl-compile repl form) opts)) - -(define (step repl) - "step FORM -Step execution." - (display "Not implemented yet\n")) - - -;;; -;;; System commands -;;; - -(define (time repl form) - "time FORM -Time execution." - (let* ((vms-start (vm-stats repl.vm)) - (gc-start (gc-run-time)) - (tms-start (times)) - (result (repl-eval repl form)) - (tms-end (times)) - (gc-end (gc-run-time)) - (vms-end (vm-stats repl.vm))) - (define (get proc start end) - (/ (- (proc end) (proc start)) internal-time-units-per-second)) - (repl-print repl result) - (display "clock utime stime cutime cstime gctime\n") - (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" - (get tms:clock tms-start tms-end) - (get tms:utime tms-start tms-end) - (get tms:stime tms-start tms-end) - (get tms:cutime tms-start tms-end) - (get tms:cstime tms-start tms-end) - (get id gc-start gc-end)) - result)) - -;;; -;;; Statistics -;;; - -(define guile-gc gc) -(define (gc repl) - "gc -Garbage collection." - (guile-gc)) - -(define (display-stat title flag field1 field2 unit) - (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@")))) - (format #t str title field1 field2 unit))) - -(define (display-stat-title title field1 field2) - (display-stat title #t field1 field2 "")) - -(define (display-diff-stat title flag this last unit) - (display-stat title flag (- this last) this unit)) - -(define (display-time-stat title this last) - (define (conv num) - (format #f "~10,2F" (/ num internal-time-units-per-second))) - (display-stat title #f (conv (- this last)) (conv this) "s")) - -(define (display-mips-stat title this-time this-clock last-time last-clock) - (define (mips time clock) - (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000)))) - (display-stat title #f - (mips (- this-time last-time) (- this-clock last-clock)) - (mips this-time this-clock) "mips")) - -(define (statistics repl) - "statistics -Display statistics." - (let ((this-tms (times)) - (this-vms (vm-stats repl.vm)) - (this-gcs (gc-stats)) - (last-tms repl.tm-stats) - (last-vms repl.vm-stats) - (last-gcs repl.gc-stats)) - ;; GC times - (let ((this-times (assq-ref this-gcs 'gc-times)) - (last-times (assq-ref last-gcs 'gc-times))) - (display-diff-stat "GC times:" #t this-times last-times "times") - (newline)) - ;; Memory size - (let ((this-cells (assq-ref this-gcs 'cells-allocated)) - (this-heap (assq-ref this-gcs 'cell-heap-size)) - (this-bytes (assq-ref this-gcs 'bytes-malloced)) - (this-malloc (assq-ref this-gcs 'gc-malloc-threshold))) - (display-stat-title "Memory size:" "current" "limit") - (display-stat "heap" #f this-cells this-heap "cells") - (display-stat "malloc" #f this-bytes this-malloc "bytes") - (newline)) - ;; Cells collected - (let ((this-marked (assq-ref this-gcs 'cells-marked)) - (last-marked (assq-ref last-gcs 'cells-marked)) - (this-swept (assq-ref this-gcs 'cells-swept)) - (last-swept (assq-ref last-gcs 'cells-swept))) - (display-stat-title "Cells collected:" "diff" "total") - (display-diff-stat "marked" #f this-marked last-marked "cells") - (display-diff-stat "swept" #f this-swept last-swept "cells") - (newline)) - ;; GC time taken - (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken)) - (last-mark (assq-ref last-gcs 'gc-mark-time-taken)) - (this-sweep (assq-ref this-gcs 'gc-sweep-time-taken)) - (last-sweep (assq-ref last-gcs 'gc-sweep-time-taken)) - (this-total (assq-ref this-gcs 'gc-time-taken)) - (last-total (assq-ref last-gcs 'gc-time-taken))) - (display-stat-title "GC time taken:" "diff" "total") - (display-time-stat "mark" this-mark last-mark) - (display-time-stat "sweep" this-sweep last-sweep) - (display-time-stat "total" this-total last-total) - (newline)) - ;; Process time spent - (let ((this-utime (tms:utime this-tms)) - (last-utime (tms:utime last-tms)) - (this-stime (tms:stime this-tms)) - (last-stime (tms:stime last-tms)) - (this-cutime (tms:cutime this-tms)) - (last-cutime (tms:cutime last-tms)) - (this-cstime (tms:cstime this-tms)) - (last-cstime (tms:cstime last-tms))) - (display-stat-title "Process time spent:" "diff" "total") - (display-time-stat "user" this-utime last-utime) - (display-time-stat "system" this-stime last-stime) - (display-time-stat "child user" this-cutime last-cutime) - (display-time-stat "child system" this-cstime last-cstime) - (newline)) - ;; VM statistics - (let ((this-time (vms:time this-vms)) - (last-time (vms:time last-vms)) - (this-clock (vms:clock this-vms)) - (last-clock (vms:clock last-vms))) - (display-stat-title "VM statistics:" "diff" "total") - (display-time-stat "time spent" this-time last-time) - (display-diff-stat "bogoclock" #f this-clock last-clock "clock") - (display-mips-stat "bogomips" this-time this-clock last-time last-clock) - (newline)) - ;; Save statistics - ;; Save statistics - (set! repl.tm-stats this-tms) - (set! repl.vm-stats this-vms) - (set! repl.gc-stats this-gcs))) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index af4befed7..4ec482866 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -24,6 +24,7 @@ :use-syntax (system base syntax) :use-module (system base language) :use-module (system vm core) + :use-module (system vm trace) :export (make-repl repl-welcome repl-prompt repl-read repl-compile repl-eval repl-print repl-compile-file repl-load-file)) @@ -63,7 +64,7 @@ (define (repl-compile repl form . opts) (let ((bytes (apply compile-in form repl.module repl.language opts))) - (if (or (memq :c opts) (memq :l opts)) + (if (or (memq :c opts) (memq :l opts) (memq :t opts) (memq :e opts)) bytes (vm-load repl.vm bytes)))) @@ -88,4 +89,6 @@ (define (repl-load-file repl file . opts) (let ((bytes (apply load-file-in file repl.module repl.language opts))) - (repl.vm (vm-load repl.vm bytes)))) + (if (memq #:t opts) (vm-trace-start! repl.vm #:a)) + (repl.vm (vm-load repl.vm bytes)) + (if (memq #:t opts) (vm-trace-end! repl.vm #:a)))) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 59e80d85c..101897475 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -135,12 +135,15 @@ (let ((setter (lambda (addr) (- (label-ref label) (1+ addr))))) (push-code! (list inst setter)))) - (($ inst n) - (push-code! (list inst n))) - - (($ inst) + (($ inst nargs) (if (instruction? inst) - (push-code! (list inst)) + (let ((pops (instruction-pops inst))) + (cond ((< pops 0) + (push-code! (list inst nargs))) + ((= pops nargs) + (push-code! (list inst))) + (else + (error "Wrong number of arguments:" inst nargs)))) (error "Unknown instruction:" inst))))) ;; ;; main @@ -242,9 +245,8 @@ ;; dump object table (cond ((null? objs) (push-code! (object->code #f))) (else - (push-code! `(mark)) (for-each dump-object! objs) - (push-code! `(vector)))))) + (push-code! `(vector ,(length objs))))))) ;; dump bytecode (push-code! `(load-program ,(bytespec-bytes spec))))) ;; diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index 4e983dc86..8a7a2167d 100644 --- a/module/system/vm/conv.scm +++ b/module/system/vm/conv.scm @@ -83,17 +83,15 @@ ((keyword? x) (push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x))))) ((list? x) - (push-code! `(mark)) (for-each dump! x) - (push-code! `(list))) + (push-code! `(list ,(length x)))) ((pair? x) (dump! (car x)) (dump! (cdr x)) (push-code! `(cons))) ((vector? x) - (push-code! `(mark)) (for-each dump! (vector->list x)) - (push-code! `(vector))) + (push-code! `(vector ,(vector-length x)))) (else (error "Cannot dump:" x)))) (reverse! stack))) @@ -110,6 +108,9 @@ (if (< n 32768) n (- n 65536)))) (('make-char8 n) (integer->char n)) + (('load-string s) s) + (('load-symbol s) (string->symbol s)) + (('load-keyword s) (symbol->keyword (string->symbol s))) (else #f))) (define-public (make-byte-decoder bytes) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 7ec24ed12..f80dc2ef9 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -64,7 +64,8 @@ (print-info addr (format #f "load-program #~A" sym) #f))) (else (let ((info (list->string code)) - (extra (original-value code (if (null? opt) #f (car opt))))) + (extra (original-value addr code + (if (null? opt) #f (car opt))))) (print-info addr info extra)))))) (for-each (lambda (sym+bytes) (format #t "Bytecode #~A:\n\n" (car sym+bytes)) @@ -86,22 +87,22 @@ meta) (newline)) -(define (original-value code table) +(define (original-value addr code objs) (define (branch-code? code) (string-match "^(br|jump)" (symbol->string (car code)))) (let ((code (code-unpack code))) (cond ((code->object code) => object->string) -;;; ((branch-code? code) -;;; (format #f "-> ~A" (+ addr (cadr code)))) + ((branch-code? code) + (format #f "-> ~A" (+ addr (cadr code)))) (else (let ((inst (car code)) (args (cdr code))) (case inst ((make-false) "#f") -;;; ((object-ref) -;;; (object->string (vector-ref objs (car args)))) - ((local-ref local-set) - ;;'(ref x)) - #f) + ((object-ref) + (if objs (object->string (vector-ref objs (car args))) #f)) +;;; ((local-ref local-set) +;;; ;;'(ref x)) +;;; #f) ;;; ((module-ref module-set) ;;; (let ((var (vector-ref objs (car args)))) ;;; (list (if (eq? inst 'module-ref) 'ref 'set) @@ -114,5 +115,5 @@ (define (print-info addr info extra) (if extra - (format #t "~4@A ~24A;; ~A\n" addr info extra) + (format #t "~4@A ~32A;; ~A\n" addr info extra) (format #t "~4@A ~A\n" addr info))) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 3b5d4f1f0..406cdc6fe 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -23,38 +23,39 @@ :use-module (system vm core) :use-module (system vm frame) :use-module (ice-9 format) - :export (vm-trace)) + :use-module (ice-9 and-let-star) + :export (vm-trace vm-trace-start! vm-trace-end!)) (define (vm-trace vm prog . opts) - (let ((flag (vm-option vm 'debug))) - (dynamic-wind - (lambda () - (set-vm-option! vm 'debug #t) - (set-vm-option! vm 'first-apply #t) - (if (memq :a 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 prog)) - (lambda () - (set-vm-option! vm 'debug flag) - (if (memq :a 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))))) + (dynamic-wind + (lambda () (apply vm-trace-start! vm opts)) + (lambda () (vm prog)) + (lambda () (apply vm-trace-end! vm opts)))) + +(define (vm-trace-start! vm . opts) + (set-vm-option! vm 'trace-first #t) + (if (memq :a 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)) + +(define (vm-trace-end! vm . opts) + (if (memq :a 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) (let ((frame (vm-current-frame vm))) - (format #t "0x~X ~20S~S\t~S\n" + (format #t "0x~8X ~20S~S\t~S\n" (vm:ip vm) (vm-fetch-code vm) (frame-variables frame) (vm-fetch-stack vm)))) (define (trace-apply vm) - (if (vm-option vm 'first-apply) - (set-vm-option! vm 'first-apply #f) ;; skip the initial program + (if (vm-option vm 'trace-first) + (set-vm-option! vm 'trace-first #f) ;; skip the initial program (let ((frame (vm-current-frame vm))) (print-prefix (frame-dynamic-link frame)) (write (frame->call frame)) diff --git a/src/instructions.c b/src/instructions.c index fc5147b74..c164d4bca 100644 --- a/src/instructions.c +++ b/src/instructions.c @@ -96,7 +96,27 @@ SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0, #define FUNC_NAME s_scm_instruction_length { SCM_VALIDATE_INSTRUCTION (1, inst); - return SCM_MAKINUM (SCM_INSTRUCTION_LEN (inst)); + return SCM_MAKINUM (SCM_INSTRUCTION_LENGTH (inst)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_pops +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_MAKINUM (SCM_INSTRUCTION_POPS (inst)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_pushes +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_MAKINUM (SCM_INSTRUCTION_PUSHES (inst)); } #undef FUNC_NAME diff --git a/src/instructions.h b/src/instructions.h index 425d1a34e..74ccf54ea 100644 --- a/src/instructions.h +++ b/src/instructions.h @@ -59,13 +59,17 @@ enum scm_opcode { struct scm_instruction { enum scm_opcode opcode; /* opcode */ char *name; /* instruction name */ - char len; /* byte length */ + char len; /* instruction length */ + char npop; /* the number of values popped */ + char npush; /* the number of values pushed */ }; #define SCM_INSTRUCTION_P(x) (scm_lookup_instruction (x)) #define SCM_INSTRUCTION_OPCODE(i) (scm_lookup_instruction (i)->opcode) #define SCM_INSTRUCTION_NAME(i) (scm_lookup_instruction (i)->name) -#define SCM_INSTRUCTION_LEN(i) (scm_lookup_instruction (i)->len) +#define SCM_INSTRUCTION_LENGTH(i) (scm_lookup_instruction (i)->len) +#define SCM_INSTRUCTION_POPS(i) (scm_lookup_instruction (i)->npop) +#define SCM_INSTRUCTION_PUSHES(i) (scm_lookup_instruction (i)->npush) #define SCM_VALIDATE_INSTRUCTION(p,x) SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P) #define SCM_INSTRUCTION(i) (&scm_instruction_table[i]) diff --git a/src/vm.c b/src/vm.c index 2d31bcddd..9696f4cf1 100644 --- a/src/vm.c +++ b/src/vm.c @@ -207,9 +207,19 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp) if (*lenp < 254) return ip; else if (*lenp == 254) - *lenp = (*ip++ << 8) + *ip++; + { + int b1 = *ip++; + int b2 = *ip++; + *lenp = (b1 << 8) + b2; + } else - *lenp = (*ip++ << 24) + (*ip++ << 16) + (*ip++ << 8) + *ip++; + { + int b1 = *ip++; + int b2 = *ip++; + int b3 = *ip++; + int b4 = *ip++; + *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4; + } return ip; } diff --git a/src/vm_engine.h b/src/vm_engine.h index 646be661b..9a5ea60ad 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -209,19 +209,6 @@ do { \ *sp = l; \ } while (0) -#define POP_LIST_MARK() \ -do { \ - SCM x; \ - SCM l = SCM_EOL; \ - POP (x); \ - while (!SCM_UNBNDP (x)) \ - { \ - CONS (l, x, l); \ - POP (x); \ - } \ - PUSH (l); \ -} while (0) - /* * Instruction operation diff --git a/src/vm_expand.h b/src/vm_expand.h index 590759399..e788d244d 100644 --- a/src/vm_expand.h +++ b/src/vm_expand.h @@ -60,17 +60,17 @@ /* * These will go to scm_instruction_table in vm.c */ -#define VM_DEFINE_INSTRUCTION(tag,name,len) \ - {VM_OPCODE (tag), name, len}, +#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) \ + {VM_OPCODE (tag), name, len, npop, npush}, #define VM_DEFINE_FUNCTION(tag,name,nargs) \ - {VM_OPCODE (tag), name, 0}, + {VM_OPCODE (tag), name, (nargs < 0) ? 1 : 0, nargs, 1}, #else #ifdef VM_INSTRUCTION_TO_LABEL /* * These will go to jump_table in vm_engine.c */ -#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_ADDR (tag), +#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_ADDR (tag), #define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag), #else @@ -78,14 +78,14 @@ /* * These will go to scm_opcode in vm.h */ -#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_OPCODE (tag), +#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_OPCODE (tag), #define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag), #else /* Otherwise */ /* * These are directly included in vm_engine.c */ -#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_TAG (tag) +#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_TAG (tag) #define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag) #endif /* VM_INSTRUCTION_TO_OPCODE */ diff --git a/src/vm_loader.c b/src/vm_loader.c index a25abc7a0..1651c22bb 100644 --- a/src/vm_loader.c +++ b/src/vm_loader.c @@ -41,7 +41,7 @@ /* This file is included in vm_engine.c */ -VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1) +VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1, 0, 1) { size_t len; @@ -58,7 +58,7 @@ VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1) SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL); } -VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1) +VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1, 0, 1) { size_t len; FETCH_LENGTH (len); @@ -67,7 +67,7 @@ VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1) NEXT; } -VM_DEFINE_INSTRUCTION (load_string, "load-string", -1) +VM_DEFINE_INSTRUCTION (load_string, "load-string", -1, 0, 1) { size_t len; FETCH_LENGTH (len); @@ -76,7 +76,7 @@ VM_DEFINE_INSTRUCTION (load_string, "load-string", -1) NEXT; } -VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1) +VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1, 0, 1) { SCM sym; size_t len; @@ -87,7 +87,7 @@ VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1) NEXT; } -VM_DEFINE_INSTRUCTION (load_module, "load-module", -1) +VM_DEFINE_INSTRUCTION (load_module, "load-module", -1, 0, 1) { size_t len; FETCH_LENGTH (len); @@ -96,7 +96,7 @@ VM_DEFINE_INSTRUCTION (load_module, "load-module", -1) NEXT; } -VM_DEFINE_INSTRUCTION (load_program, "load-program", -1) +VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1) { size_t len; SCM prog, x; @@ -127,14 +127,14 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1) NEXT; } -VM_DEFINE_INSTRUCTION (link, "link", 0) +VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1) { sp[1] = scm_c_env_vcell (sp[1], sp[0], 1); DROP (); NEXT; } -VM_DEFINE_INSTRUCTION (link_current_module, "link/current-module", 0) +VM_DEFINE_INSTRUCTION (link_current_module, "link/current-module", 0, 1, 1) { SCM mod = scm_current_module (); SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), diff --git a/src/vm_scheme.c b/src/vm_scheme.c index 99e9e3093..381b14213 100644 --- a/src/vm_scheme.c +++ b/src/vm_scheme.c @@ -128,13 +128,15 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2) VM_DEFINE_FUNCTION (list, "list", -1) { - POP_LIST_MARK (); + ARGSN (an); + POP_LIST (an); NEXT; } VM_DEFINE_FUNCTION (vector, "vector", -1) { - POP_LIST_MARK (); + ARGSN (an); + POP_LIST (an); *sp = scm_vector (*sp); NEXT; } diff --git a/src/vm_system.c b/src/vm_system.c index 6c8f86228..3d094c66a 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -47,12 +47,12 @@ */ /* This must be the first instruction! */ -VM_DEFINE_INSTRUCTION (nop, "nop", 0) +VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0) { NEXT; } -VM_DEFINE_INSTRUCTION (halt, "halt", 0) +VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0) { SCM ret = *sp; HALT_HOOK (); @@ -61,13 +61,13 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0) return ret; } -VM_DEFINE_INSTRUCTION (drop, "drop", 0) +VM_DEFINE_INSTRUCTION (drop, "drop", 0, 1, 0) { DROP (); NEXT; } -VM_DEFINE_INSTRUCTION (dup, "dup", 0) +VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1) { PUSH (*sp); NEXT; @@ -78,55 +78,55 @@ VM_DEFINE_INSTRUCTION (dup, "dup", 0) * Object creation */ -VM_DEFINE_INSTRUCTION (void, "void", 0) +VM_DEFINE_INSTRUCTION (void, "void", 0, 0, 1) { PUSH (SCM_UNSPECIFIED); NEXT; } -VM_DEFINE_INSTRUCTION (mark, "mark", 0) +VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1) { PUSH (SCM_UNDEFINED); NEXT; } -VM_DEFINE_INSTRUCTION (make_true, "make-true", 0) +VM_DEFINE_INSTRUCTION (make_true, "make-true", 0, 0, 1) { PUSH (SCM_BOOL_T); NEXT; } -VM_DEFINE_INSTRUCTION (make_false, "make-false", 0) +VM_DEFINE_INSTRUCTION (make_false, "make-false", 0, 0, 1) { PUSH (SCM_BOOL_F); NEXT; } -VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0) +VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1) { PUSH (SCM_EOL); NEXT; } -VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1) +VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1) { PUSH (SCM_MAKINUM ((signed char) FETCH ())); NEXT; } -VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0) +VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1) { PUSH (SCM_MAKINUM (0)); NEXT; } -VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0) +VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1) { PUSH (SCM_MAKINUM (1)); NEXT; } -VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2) +VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1) { int h = FETCH (); int l = FETCH (); @@ -134,7 +134,7 @@ VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2) NEXT; } -VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1) +VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1) { PUSH (SCM_MAKE_CHAR (FETCH ())); NEXT; @@ -154,7 +154,7 @@ VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1) #define VARIABLE_REF(v) SCM_CDR (v) #define VARIABLE_SET(v,o) SCM_SETCDR (v, o) -VM_DEFINE_INSTRUCTION (external, "external", 1) +VM_DEFINE_INSTRUCTION (external, "external", 1, 0, 0) { int n = FETCH (); while (n-- > 0) @@ -164,25 +164,25 @@ VM_DEFINE_INSTRUCTION (external, "external", 1) /* ref */ -VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1) +VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1) { PUSH (OBJECT_REF (FETCH ())); NEXT; } -VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1) +VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); NEXT; } -VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0) +VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0, 0, 1) { PUSH (LOCAL_REF (0)); NEXT; } -VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1) +VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1) { unsigned int i; SCM e = external; @@ -192,26 +192,13 @@ VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1) NEXT; } -VM_DEFINE_INSTRUCTION (module_ref, "module-ref", 1) -{ - int i = FETCH (); - SCM o, x = OBJECT_REF (i); - o = VARIABLE_REF (x); - if (SCM_UNBNDP (o)) - { - err_args = SCM_LIST1 (SCM_CAR (x)); - goto vm_error_unbound; - } - PUSH (o); - NEXT; -} - -VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0) +VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1) { SCM x = *sp; SCM o = VARIABLE_REF (x); if (SCM_UNBNDP (o)) { + /* Try autoload here */ err_args = SCM_LIST1 (SCM_CAR (x)); goto vm_error_unbound; } @@ -221,14 +208,14 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0) /* set */ -VM_DEFINE_INSTRUCTION (local_set, "local-set", 1) +VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0) { LOCAL_SET (FETCH (), *sp); DROP (); NEXT; } -VM_DEFINE_INSTRUCTION (external_set, "external-set", 1) +VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0) { unsigned int i; SCM e = external; @@ -239,16 +226,7 @@ VM_DEFINE_INSTRUCTION (external_set, "external-set", 1) NEXT; } -VM_DEFINE_INSTRUCTION (module_set, "module-set", 1) -{ - int i = FETCH (); - SCM x = OBJECT_REF (i); - VARIABLE_SET (x, *sp); - DROP (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0) +VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0) { VARIABLE_SET (sp[0], sp[1]); sp += 2; @@ -269,37 +247,37 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0) NEXT; \ } -VM_DEFINE_INSTRUCTION (br_if, "br-if", 1) +VM_DEFINE_INSTRUCTION (br_if, "br-if", 1, 0, 0) { BR (!SCM_FALSEP (*sp)); } -VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1) +VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1, 0, 0) { BR (SCM_FALSEP (*sp)); } -VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1) +VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1, 0, 0) { BR (SCM_EQ_P (sp[0], sp--[1])); } -VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1) +VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1, 0, 0) { BR (!SCM_EQ_P (sp[0], sp--[1])); } -VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1) +VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1, 0, 0) { BR (SCM_NULLP (*sp)); } -VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1) +VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1, 0, 0) { BR (!SCM_NULLP (*sp)); } -VM_DEFINE_INSTRUCTION (jump, "jump", 1) +VM_DEFINE_INSTRUCTION (jump, "jump", 1, 0, 0) { ip += (signed char) FETCH (); NEXT; @@ -310,14 +288,14 @@ VM_DEFINE_INSTRUCTION (jump, "jump", 1) * Subprogram call */ -VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0) +VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1) { SYNC (); *sp = scm_c_make_vclosure (*sp, external); NEXT; } -VM_DEFINE_INSTRUCTION (call, "call", 1) +VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1) { POP (program); nargs = FETCH (); @@ -368,7 +346,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1) +VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1) { SCM x; POP (x); @@ -438,7 +416,7 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1) goto vm_error_wrong_type_apply; } -VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1) +VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1) { SYNC (); PUSH (capture_vm_cont (vmp)); @@ -447,7 +425,7 @@ VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1) goto vm_call; } -VM_DEFINE_INSTRUCTION (return, "return", 0) +VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1) { SCM ret; vm_return: @@ -463,23 +441,6 @@ VM_DEFINE_INSTRUCTION (return, "return", 0) NEXT; } - -/* - * Exception handling - */ - -VM_DEFINE_INSTRUCTION (raise, "raise", 1) -{ -} - -VM_DEFINE_INSTRUCTION (catch, "catch", 0) -{ -} - -VM_DEFINE_INSTRUCTION (stack_catch, "stach_catch", 0) -{ -} - /* Local Variables: c-file-style: "gnu"