From cdd8bfcddbb7a8171cb09dbc0c207d614b67c903 Mon Sep 17 00:00:00 2001 From: okuoku Date: Tue, 2 Aug 2022 01:46:25 +0900 Subject: [PATCH] Add `enter` instruction and remove Base92 encoding --- max-tc.scm | 2 +- yuniribbit/rsc.sls | 754 ++------------------------------------------- yuniribbit/rvm.sls | 240 ++++++++------- 3 files changed, 150 insertions(+), 846 deletions(-) diff --git a/max-tc.scm b/max-tc.scm index a6fc97f..3dbfa4c 100644 --- a/max-tc.scm +++ b/max-tc.scm @@ -191,7 +191,7 @@ ;; Symbols (R4RS section 6.4). (define symbol? (instance? symbol-type)) -(define (string->uninterned-symbol str) (rib #f str symbol-type)) +(define (string->uninterned-symbol str) (rib "unspecified" str symbol-type)) (define (symbol->string sym) (if (symbol? sym) diff --git a/yuniribbit/rsc.sls b/yuniribbit/rsc.sls index 6723b7a..95cb94a 100644 --- a/yuniribbit/rsc.sls +++ b/yuniribbit/rsc.sls @@ -1,6 +1,5 @@ (library (yuniribbit rsc) - (export compile-program - generate-code) + (export compile-program) (import (yuni scheme) (yuni util files) (yuni hashtables)) @@ -196,11 +195,12 @@ (exit 20) )) -(define jump/call-op 'jump/call) -(define set-op 'set) -(define get-op 'get) -(define const-op 'const) -(define if-op 'if) +(define jump/call-op 0) +(define set-op 1) +(define get-op 2) +(define const-op 3) +(define if-op 4) +(define enter-op 5) ;; yuniribbit ;;;---------------------------------------------------------------------------- @@ -317,7 +317,7 @@ '()) (if (null? (ctx-cte ctx)) cont - (gen-call (use-symbol ctx 'close) cont))))) + (gen-call #f (use-symbol ctx 'close) cont))))) ((eqv? first 'begin) (comp-begin ctx (cdr expr) cont)) @@ -334,11 +334,11 @@ (else (let ((args (cdr expr))) (if (symbol? first) - (comp-call ctx + (comp-call 0 ctx args - (lambda (ctx) + (lambda (argc ctx) (let ((v (lookup first (ctx-cte ctx) 0))) - (gen-call v cont)))) + (gen-call argc v cont)))) (comp-bind ctx '(_) (cons first '()) @@ -349,10 +349,11 @@ ;; self-evaluating (rib const-op expr cont)))) -(define (gen-call v cont) - (if (eqv? cont tail) - (rib jump/call-op v 0) ;; jump - (rib jump/call-op v cont))) ;; call +(define (gen-call argc v cont) + (let ((g (if (eqv? cont tail) + (rib jump/call-op v 0) ;; jump + (rib jump/call-op v cont)))) ;; call + (if argc (rib enter-op argc g) g))) (define (gen-assign v cont) (rib set-op v (gen-noop cont))) @@ -404,14 +405,14 @@ (comp-begin ctx (cdr exprs) cont)) cont))) -(define (comp-call ctx exprs k) +(define (comp-call argc ctx exprs k) (if (pair? exprs) (comp ctx (car exprs) - (comp-call (ctx-cte-set ctx (cons #f (ctx-cte ctx))) + (comp-call (+ 1 argc) (ctx-cte-set ctx (cons #f (ctx-cte ctx))) (cdr exprs) k)) - (k ctx))) + (k argc ctx))) (define (lookup var cte i) (if (pair? cte) @@ -878,722 +879,5 @@ live-globals) -;;;---------------------------------------------------------------------------- - -;; RVM code encoding. - -(define eb 92) ;; encoding base (strings have 92 characters that are not escaped and not space) -;;(define eb 256) -(define eb/2 (quotient eb 2)) - -(define get-int-short 10) ;; 0 <= N <= 9 are encoded with 1 byte -(define const-int-short 11) ;; 0 <= N <= 10 are encoded with 1 byte -(define const-proc-short 4) ;; 0 <= N <= 3 are encoded with 1 byte -(define jump-sym-short 20) ;; 0 <= N <= 19 are encoded with 1 byte - -(define call-sym-short (- eb ;; use rest to encode calls to globals - (+ const-int-short - (+ const-proc-short - (+ get-int-short - (+ jump-sym-short - 17)))))) - -(define jump-start 0) -(define jump-int-start (+ jump-start jump-sym-short)) -(define jump-sym-start (+ jump-int-start 1)) -(define call-start (+ jump-sym-start 2)) -(define call-int-start (+ call-start call-sym-short)) -(define call-sym-start (+ call-int-start 1)) -(define set-start (+ call-sym-start 2)) -(define set-int-start (+ set-start 0)) -(define set-sym-start (+ set-int-start 1)) -(define get-start (+ set-sym-start 2)) -(define get-int-start (+ get-start get-int-short)) -(define get-sym-start (+ get-int-start 1)) -(define const-start (+ get-sym-start 2)) -(define const-int-start (+ const-start const-int-short)) -(define const-sym-start (+ const-int-start 1)) -(define const-proc-start (+ const-sym-start 2)) -(define if-start (+ const-proc-start (+ const-proc-short 1))) - -(define (encode proc exports) - - (define syms (make-table)) - - (define built-constants '()) - - (define (build-constant o tail) - (cond ((or (memv o '(#f #t ())) - (assq o built-constants)) - (let ((v (constant-global-var o))) - (rib get-op - (scan-opnd v 1) - tail))) - ((symbol? o) - (rib const-op - (scan-opnd o 2) - tail)) - ((number? o) - (if (< o 0) - (rib const-op - 0 - (rib const-op - (- 0 o) - (rib jump/call-op - (scan-opnd '- 0) - tail))) - (rib const-op - o - tail))) - ((pair? o) - (build-constant (car o) - (build-constant (cdr o) - (rib const-op - pair-type - (rib jump/call-op - (scan-opnd 'rib 0) - tail))))) - ((string? o) - (let ((chars (map char->integer (string->list o)))) - (build-constant chars - (build-constant (length chars) - (rib const-op - string-type - (rib jump/call-op - (scan-opnd 'rib 0) - tail)))))) - ((vector? o) - (let ((elems (vector->list o))) - (build-constant elems - (build-constant (length elems) - (rib const-op - vector-type - (rib jump/call-op - (scan-opnd 'rib 0) - tail)))))) - (else - (error "can't build constant" o)))) - - (define (build-constant-in-global-var o v) - (let ((code (build-constant o 0))) - (set! built-constants (cons (cons o (cons v code)) built-constants)) - v)) - - (define (add-init-primitives tail) - - (define (prim-code sym tail) - (rib const-op - (cadr (assq sym primitives0)) ;; get index - (rib const-op - 0 - (rib const-op - procedure-type - (rib jump/call-op - (scan-opnd 'rib 0) - (rib set-op - (scan-opnd sym 3) - tail)))))) - - (let loop ((lst (cdr primitives0)) ;; skip rib primitive that is predefined - (tail tail)) - (if (pair? lst) - (loop (cdr lst) - (let* ((sym (car (car lst))) - (descr (table-ref syms sym #f))) - (if (and descr - (or (< 0 (field0 descr)) - (< 0 (field1 descr)) - (< 0 (field2 descr)))) - (prim-code sym tail) - tail))) - tail))) - - (define (append-code code tail) - (if (eqv? code 0) - tail - (rib (field0 code) (field1 code) (append-code (field2 code) tail)))) - - (define (add-init-constants tail) - (let loop ((lst built-constants) (tail tail)) - (if (pair? lst) - (let* ((x (car lst)) - (o (car x)) - (v (cadr x)) - (code (cddr x))) - (loop (cdr lst) - (append-code code (rib set-op v tail)))) - tail))) - - (define (add-init-code! proc) - (let ((code (field0 proc))) - (field2-set! code - (add-init-primitives - (add-init-constants - (field2 code)))))) - - (define constant-counter 0) - - (define (constant-global-var o) - (cond ((eqv? o #f) - 'false) - ((eqv? o #t) - 'true) - ((eqv? o '()) - 'nil) - (else - (let ((x (assq o built-constants))) - (if x - (cadr x) - (let ((v (string->symbol - (string-append "_" - (number->string constant-counter))))) - (set! constant-counter (+ constant-counter 1)) - (build-constant-in-global-var o v) - (scan-opnd v 3) - v)))))) - - (define (use-in-call sym) - (scan-opnd sym 0) - sym) - - (define (scan-proc proc) - (scan (next (procedure-code proc)))) - - (define (scan-opnd o pos) - (scan-opnd-aux o pos) - o) - - (define (scan-opnd-aux o pos) - (cond ((symbol? o) - (let ((descr - (or (table-ref syms o #f) - (let ((descr (rib 0 0 0))) - (table-set! syms o descr) - descr)))) - (cond ((= pos 0) - (field0-set! descr (+ 1 (field0 descr)))) - ((= pos 1) - (field1-set! descr (+ 1 (field1 descr)))) - ((= pos 2) - (field2-set! descr (+ 1 (field2 descr))))))) - ((procedure2? o) - (scan-proc o)))) - - (define (scan code) - (if (rib? code) - (begin - (scan-instr code) - (scan (next code))))) - - (define (scan-instr code) - (let ((op (oper code)) - (o (opnd code))) - (cond ((eqv? op if-op) - (scan o)) - ((eqv? op jump/call-op) - (scan-opnd o 0)) ;; 0 = jump/call - ((eqv? op get-op) - (scan-opnd o 1)) ;; 1 = get - ((eqv? op const-op) - (if (or (symbol? o) - (procedure2? o) - (and (number? o) (>= o 0))) - (scan-opnd o 2) ;; 2 = const - (let ((v (constant-global-var o))) - (field0-set! code get-op) - (field1-set! code v) - (scan-opnd v 1)))) ;; 1 = get - ((eqv? op set-op) - (scan-opnd o 3))))) ;; 3 = set - - (define (encode-sym o) - (let ((descr (table-ref syms o #f))) - (field0 descr))) - - (define (encode-long1 code n stream) - (cons code (encode-n n stream))) - - (define (encode-long2 code0 n stream) - (let ((s (encode-n n stream))) - (let ((x (car s))) - (if (= x (+ eb/2 1)) - (cons (+ code0 1) (cdr s)) - (cons code0 s))))) - - (define (encode-n n stream) - (encode-n-aux n stream stream)) - - (define (encode-n-aux n stream end) - (let ((q (quotient n eb/2))) - (let ((r (- n (* q eb/2)))) - (let ((t (cons (if (eqv? stream end) r (+ r eb/2)) stream))) - (if (= q 0) - t - (encode-n-aux q t end)))))) - - (define (enc-proc proc stream) - (let ((code (procedure-code proc))) - (let ((nparams (field0 code))) - (enc (next code) - (if (< nparams - const-proc-short) - (cons (+ const-proc-start - nparams) - stream) - (encode-long1 (+ const-proc-start - const-proc-short) - nparams - stream)))))) - - (define (number? x) (integer? x)) - - (define (enc code stream) - (if (rib? code) - (let ((op (oper code))) - (cond ((eqv? op jump/call-op) - (if (eqv? 0 (next code)) ;; jump? - - (let ((o (opnd code))) - (cond ((number? o) - (encode-long1 jump-int-start - o - stream)) - ((symbol? o) - (let ((x (encode-sym o))) - (if (< x jump-sym-short) - (cons (+ jump-start x) - stream) - (encode-long2 jump-sym-start - x - stream)))) - (else - (error "can't encode jump" o)))) - - (enc (next code) - (let ((o (opnd code))) - (cond ((number? o) - (encode-long1 call-int-start - o - stream)) - ((symbol? o) - (let ((x (encode-sym o))) - (if (< x call-sym-short) - (cons (+ call-start x) - stream) - (encode-long2 call-sym-start - x - stream)))) - (else - (error "can't encode call" o))))))) - - ((eqv? op set-op) - (enc (next code) - (let ((o (opnd code))) - (cond ((number? o) - (encode-long1 set-int-start - o - stream)) - ((symbol? o) - (encode-long2 set-sym-start - (encode-sym o) - stream)) - (else - (error "can't encode set" o)))))) - - ((eqv? op get-op) - (enc (next code) - (let ((o (opnd code))) - (cond ((number? o) - (if (< o get-int-short) - (cons (+ get-start o) - stream) - (encode-long1 get-int-start - o - stream))) - ((symbol? o) - (encode-long2 get-sym-start - (encode-sym o) - stream)) - (else - (error "can't encode get" o)))))) - - ((eqv? op const-op) - (enc (next code) - (let ((o (opnd code))) - (cond ((number? o) - (if (< o const-int-short) - (cons (+ const-start o) - stream) - (encode-long1 const-int-start - o - stream))) - ((symbol? o) - (encode-long2 const-sym-start - (encode-sym o) - stream)) - ((procedure2? o) - (enc-proc o stream)) - (else - (error "can't encode const" o)))))) - - ((eqv? op if-op) - (enc (next code) - (enc (opnd code) - (cons if-start - stream)))) - - (else - (error "unknown op" op)))) - (error "rib expected" '()))) - - (define (ordering sym-descr) - (let ((sym (car sym-descr))) - (let ((pos (member sym predefined))) - (if pos - (+ 9999999 (length pos)) - (let ((descr (cdr sym-descr))) - (field0 descr)))))) - - (for-each (lambda (sym) (scan-opnd sym 3)) predefined) - - (scan-proc proc) - - (add-init-code! proc) - - (let ((lst - (list-sort - (lambda (a b) - (< (ordering b) (ordering a))) - (table->list syms)))) - - (let loop1 ((i 0) (lst lst) (symbols '())) - (if (and (pair? lst) (< i call-sym-short)) - (let ((s (car lst))) - (let ((sym (car s))) - (let ((descr (cdr s))) - (let ((x (assq sym exports))) - (let ((symbol (if x (cdr x) (str->uninterned-symbol "")))) - (field0-set! descr i) - (loop1 (+ i 1) (cdr lst) (cons symbol symbols))))))) - (let loop2 ((i i) (lst2 lst) (symbols symbols)) - (if (pair? lst2) - (let ((s (car lst2))) - (let ((sym (car s))) - (let ((x (assq sym exports))) - (if x - (let ((symbol (cdr x))) - (let ((descr (cdr s))) - (field0-set! descr i) - (loop2 (+ i 1) (cdr lst2) (cons symbol symbols)))) - (loop2 i (cdr lst2) symbols))))) - (let loop3 ((i i) (lst3 lst) (symbols symbols)) - (if (pair? lst3) - (let ((s (car lst3))) - (let ((sym (car s))) - (let ((x (assq sym exports))) - (if x - (loop3 i (cdr lst3) symbols) - (let ((symbol (str->uninterned-symbol ""))) - (let ((descr (cdr s))) - (field0-set! descr i) - (loop3 (+ i 1) (cdr lst3) (cons symbol symbols)))))))) - (let loop4 ((symbols* symbols)) - (if (and (pair? symbols*) - (string=? (symbol->str (car symbols*)) "")) - (loop4 (cdr symbols*)) - - (let ((stream - (enc-proc proc '()))) - (string-append - (stream->string - (encode-n (- (length symbols) - (length symbols*)) - '())) - (string-append - (string-concatenate - (map (lambda (s) - (let ((str (symbol->str s))) - (list->string - (reverse (string->list str))))) - symbols*) - ",") - (string-append - ";" - (stream->string stream))))))))))))))) - -(define (stream->string stream) - (list->string - (map (lambda (n) - (let ((c (+ n 35))) - (integer->char (if (= c 92) 33 c)))) - stream))) - -(define (string->codes string) - (map char->integer (string->list string))) - -;;;---------------------------------------------------------------------------- - -;; Source code reading. - -(define (root-dir) - (rsc-path-directory (or (script-file) (executable-path)))) - -(define (read-all) - (let ((x (read))) - (if (eof-object? x) - '() - (cons x (read-all))))) - -(define (read-from-file path) - (file->sexp-list path)) - -(define (read-library lib-path) - (read-from-file - (if (equal? (rsc-path-extension lib-path) "") - (path-expand (string-append lib-path ".scm") - (path-expand "lib" (root-dir))) - lib-path))) - -(define (read-program lib-path src-path) - (append (read-library lib-path) - (if (equal? src-path "-") - (read-all) - (read-from-file src-path)))) - -;;;---------------------------------------------------------------------------- - -;; Target code generation. - -(define (string-from-file path) - (let ((str* (file->string-list path))) - (string-concatenate str* ""))) - -(define (generate-code target verbosity input-path minify? proc-and-exports) - (let* ((proc - (car proc-and-exports)) - (exports - (cdr proc-and-exports)) - (encoded-program - (encode proc exports)) - (vm-source - (if (equal? target "rvm") - "" - (string-from-file - (path-expand (string-append - "host/" - (string-append - target - (string-append "/rvm." target))) - (root-dir))))) - (input - (string-append encoded-program - (if input-path - (string-from-file input-path) - "")))) - - (if (>= verbosity 1) - (begin - (display "*** RVM code length: ") - (display (string-length input)) - (display " bytes\n"))) - - (let* ((target-code-before-minification - (if (equal? target "rvm") - input - (let ((sample - ");'u?>vD?>vRD?>vRA?>vRA?>vR:?>vR=!(:lkm!':lkv6y")) ;; RVM code that prints HELLO! - (string-replace - (string-replace - (string-replace - (string-replace - vm-source - sample - input) - (rvm-code-to-bytes sample " ") - (rvm-code-to-bytes input " ")) - (rvm-code-to-bytes sample ",") - (rvm-code-to-bytes input ",")) - "RVM code that prints HELLO!" - "RVM code of the program")))) - (target-code - (if (or (not minify?) (equal? target "rvm")) - target-code-before-minification - (pipe-through - (path-expand - (string-append - "host/" - (string-append target "/minify")) - (root-dir)) - target-code-before-minification)))) - target-code))) - -(define (rvm-code-to-bytes rvm-code sep) - (string-concatenate - (map (lambda (c) (number->string (char->integer c))) - (string->list rvm-code)) - sep)) - -(define (string-replace str pattern replacement) - (let ((len-pattern (string-length pattern)) - (len-replacement (string-length replacement))) - (let loop1 ((i 0) (j 0) (out '())) - (if (<= (+ j len-pattern) (string-length str)) - (let loop2 ((k (- len-pattern 1))) - (if (< k 0) - (let ((end (+ j len-pattern))) - (loop1 end - end - (cons replacement (cons (substring str i j) out)))) - (if (char=? (string-ref str (+ j k)) (string-ref pattern k)) - (loop2 (- k 1)) - (loop1 i - (+ j 1) - out)))) - (string-concatenate - (reverse (cons (substring str i (string-length str)) out)) - ""))))) - -(define (write-target-code output-path target-code) - (if (equal? output-path "-") - (display target-code) - (call-with-output-file - output-path - (lambda (p) - (display target-code p))))) - -;;;---------------------------------------------------------------------------- - -;; Compiler entry points. - -(define (pipeline-compiler) - - ;; This version of the compiler reads the source code on stdin and - ;; outputs the compacted RVM code on stdout. The program source - ;; code must be prefixed by the runtime library's source code. - ;; - ;; A Scheme file can be combined with the library and compiled to - ;; RVM code with this command: - ;; - ;; $ echo '(display "hello!\n")' > hello.scm - ;; $ cat lib/max.scm hello.scm | gsi rsc.scm > code.rvm - ;; - ;; Alternatively, the rsc shell script can be used to automate - ;; the creation of a complete executable target program: - ;; - ;; $ ./rsc -t py -l max hello.scm - ;; $ python3 hello.scm.py - ;; hello! - - (display - (generate-code - "rvm" ;; target - 0 ;; verbosity - #f ;; input-path - #f ;; minify? - (compile-program - 0 ;; verbosity - (read-all))))) - - - -(define (fancy-compiler src-path - output-path - target - input-path - lib-path - minify? - verbosity) - - ;; This version of the compiler reads the program and runtime library - ;; source code from files and it supports various options. It can - ;; merge the compacted RVM code with the implementation of the RVM - ;; for a specific target and minify the resulting target code. - - (write-target-code - output-path - (generate-code - target - verbosity - input-path - minify? - (compile-program - verbosity - (read-program lib-path src-path))))) - -(define (parse-cmd-line args) - (if (null? (cdr args)) - - (pipeline-compiler) - - (let ((verbosity 0) - (target "rvm") - (input-path #f) - (output-path #f) - (lib-path "default") - (src-path #f) - (minify? #f)) - - (let loop ((args (cdr args))) - (if (pair? args) - (let ((arg (car args)) - (rest (cdr args))) - (cond ((and (pair? rest) (member arg '("-t" "--target"))) - (set! target (car rest)) - (loop (cdr rest))) - ((and (pair? rest) (member arg '("-i" "--input"))) - (set! input-path (car rest)) - (loop (cdr rest))) - ((and (pair? rest) (member arg '("-o" "--output"))) - (set! output-path (car rest)) - (loop (cdr rest))) - ((and (pair? rest) (member arg '("-l" "--library"))) - (set! lib-path (car rest)) - (loop (cdr rest))) - ((and (pair? rest) (member arg '("-m" "--minify"))) - (set! minify? #t) - (loop rest)) - ((member arg '("-v" "--v")) - (set! verbosity (+ verbosity 1)) - (loop rest)) - ((member arg '("-vv" "--vv")) - (set! verbosity (+ verbosity 2)) - (loop rest)) - ((member arg '("-vvv" "--vvv")) - (set! verbosity (+ verbosity 3)) - (loop rest)) - ((member arg '("-q")) ;; silently ignore Chicken's -q option - (loop rest)) - (else - (if (and (>= (string-length arg) 2) - (string=? (substring arg 0 1) "-")) - (begin - (display "*** ignoring option ") - (display arg) - (newline) - (loop rest)) - (begin - (set! src-path arg) - (loop rest)))))))) - - (if (not src-path) - - (begin - (display "*** a Scheme source file must be specified\n") - (exit-program-abnormally)) - - (fancy-compiler - src-path - (or output-path - (if (or (equal? src-path "-") (equal? target "rvm")) - "-" - (string-append - src-path - (string-append "." target)))) - target - input-path - lib-path - minify? - verbosity))))) - ;;;---------------------------------------------------------------------------- ) diff --git a/yuniribbit/rvm.sls b/yuniribbit/rvm.sls index 99a242e..3a79d7f 100644 --- a/yuniribbit/rvm.sls +++ b/yuniribbit/rvm.sls @@ -1,6 +1,7 @@ (library (yuniribbit rvm) (export rvm) (import (yuni scheme) + (yuni hashtables) (yuniribbit util debug-expand)) (define pair-type 0) @@ -32,9 +33,9 @@ (define (_string->uninterned-symbol str) (_rib _false str symbol-type)) -(define _false (_rib 0 0 singleton-type)) -(define _true (_rib 0 0 singleton-type)) -(define _nil (_rib 0 0 singleton-type)) +(define _false (_rib "false" 0 singleton-type)) +(define _true (_rib "true" 0 singleton-type)) +(define _nil (_rib "nil" 0 singleton-type)) (define (_list-tail lst i) (if (< 0 i) @@ -179,12 +180,6 @@ (let loop ((stack stack)) (if (_rib? (_field2 stack)) stack (loop (_cdr stack))))) -(define (get-var stack opnd) - (_field0 (if (_rib? opnd) opnd (_list-tail stack opnd)))) - -(define (set-var stack opnd val) - (_field0-set! (if (_rib? opnd) opnd (_list-tail stack opnd)) val)) - (define (prim0 f) (lambda (stack) (_cons (f) stack))) @@ -216,108 +211,73 @@ (define (boolean x) (if x _true _false)) -(define (rvm input done-cb) +(define (import-string x) + (let loop ((acc "") + (cur (_field0 x))) + (if (_pair? cur) + (loop (string-append + acc + (list->string (list (integer->char (_car cur))))) + (_cdr cur)) + acc))) + +(define (rvm code+exports input done-cb) (define not-yet (cons 0 0)) (define output-result not-yet) (define output-buf "") (define pos 0) + (define code (car code+exports)) + (define exports (cdr code+exports)) + (define globals (make-symbol-hashtable)) + (define vmsym? (instance? symbol-type)) + (define symcache (make-symbol-hashtable)) + (define (symeq? sym rib) + (and (vmsym? rib) + (let ((x (hashtable-ref symcache sym #f))) + (eq? x rib)))) + + (define (get-var stack opnd) + (_field0 + (cond + ((_rib? opnd) + opnd) + ((symbol? opnd) (hashtable-ref globals opnd "NOT-FOUND!!")) + (else (_list-tail stack opnd))))) + + (define (set-var stack opnd val) + (_field0-set! + (cond + ((_rib? opnd) opnd) + ((symbol? opnd) + (when (eq? 'symtbl opnd) + ;; Handle delayed "code -> VM" import + (when (_pair? val) + (let ((sym (_car val))) + (unless (eqv? symbol-type (_field2 sym)) + (error "Tried to add non-symbol!!")) + (when (string=? "unspecified" (_field0 sym)) + (let ((name (string->symbol (import-string (_field1 sym))))) + (hashtable-set! symcache name sym) + (let ((v (hashtable-ref globals name #f))) + (when v + (_field0-set! sym (_field0 v))))))))) + (let ((f (hashtable-ref globals opnd #f))) + (cond + (f f) + (else + (hashtable-set! globals opnd + (_string->uninterned-symbol + (symbol->string opnd))) + (hashtable-ref globals opnd #f))))) + (else (_list-tail stack opnd))) + val)) + (define (get-byte) (let ((x (char->integer (string-ref input pos)))) (set! pos (+ pos 1)) x)) - (define (decode) - - (define eb/2 46) ;; half of encoding base (92) - - (define (get-code) - (let ((x (- (get-byte) 35))) - (if (< x 0) 57 x))) - - (define (get-int n) - (let ((x (get-code)) - (y (* n eb/2))) - (if (< x eb/2) - (+ y x) - (get-int (+ y (- x eb/2)))))) - - (define (build-symtbl) - - (define (add-symbol chars symtbl) - (_cons (_string->uninterned-symbol (_list->string chars)) - symtbl)) - - (let loop1 ((n (get-int 0)) (symtbl _nil)) - (if (< 0 n) - (loop1 (- n 1) (add-symbol _nil symtbl)) - (let loop2 ((symtbl symtbl)) - (let loop3 ((chars _nil)) - (let ((x (get-byte))) - (if (= x 44) ;; #\, separates symbols - (loop2 (add-symbol chars symtbl)) - (if (= x 59) ;; #\; terminates symbol list - (add-symbol chars symtbl) - (loop3 (_cons x chars)))))))))) - - (let ((symtbl (build-symtbl))) - - (define (decode-loop stack) - - (define (sym n) - (_car (_list-tail symtbl n))) - - (define (add-instruction op opnd stack) - ;; (pp (list (vector-ref '#(jump/call set get const if) op) opnd)) - (_set-car! stack (_rib op opnd (_car stack))) - (decode-loop stack)) - - (let ((x (get-code))) - (let loop ((op 0) (n x)) - (let ((d (vector-ref '#(20 30 0 10 11 4) op))) - (if (< (+ 2 d) n) - (loop (+ op 1) (- n (+ d 3))) - (if (< 90 x) - (add-instruction 4 ;; if - (_car stack) - (_cdr stack)) - (let ((stack (if (= op 0) (_cons 0 stack) stack)) - (opnd (if (< n d) - (if (< op 3) - (sym n) - n) - (if (= n d) - (get-int 0) - (sym (get-int (- (- n d) 1))))))) - (if (< 4 op) - (let ((proc (_rib - (_rib opnd 0 (_car stack)) - _nil - procedure-type)) - (stack (_cdr stack))) - (if (_rib? stack) - (add-instruction 3 ;; const-proc - proc - stack) - proc)) - (add-instruction (if (< 0 op) (- op 1) 0) - opnd - stack))))))))) - - (let ((main-proc (decode-loop 0))) - - ;; set predefined globals (always 4 first in the symbol table) - - (define (set-global val) - (_field0-set! (_car symtbl) val) - (set! symtbl (_cdr symtbl))) - - (set-global (_rib 0 symtbl procedure-type)) ;; rib = primitive 0 - (set-global _false) ;; false = #f - (set-global _true) ;; true = #t - (set-global _nil) ;; nil = () - - main-proc))) (define (run pc stack) (debug-expand (start-step stack)) (let ((instr (_field0 pc)) @@ -383,8 +343,12 @@ (if tracing (trace-instruction "const" opnd))) - (run next - (_cons opnd stack))) + (let ((v (cond + ((number? opnd) opnd) + ((null? opnd) _nil) + ((boolean? opnd) (if opnd _true _false)) + (else opnd)))) + (run next (_cons v stack)))) ((4) ;; if (debug-expand @@ -392,12 +356,41 @@ (trace-instruction "if" #f))) (run (if (eqv? (_car stack) _false) next opnd) (_cdr stack))) + ((5) ;; enter (yuniribbit) + (debug-expand + (if tracing + (trace-instruction "enter" opnd))) + (run next stack)) (else ;; halt (debug-expand (if tracing (trace-instruction "halt" #f))) #f)))) + (define primitives0 '((rib 0) + (id 1) + (arg1 2) + (arg2 3) + (close 4) + (rib? 5) + (field0 6) + (field1 7) + (field2 8) + (field0-set! 9) + (field1-set! 10) + (field2-set! 11) + (eqv? 12) + (< 13) + (+ 14) + (- 15) + (* 16) + (quotient 17) + (getchar 18) + (putchar 19) + (exit 20) + )) + + (define primitives (vector (prim3 _rib) ;; 0 (prim1 (lambda (x) x)) ;; 1 @@ -415,7 +408,16 @@ (prim2 (lambda (x y) (_field0-set! x y) y)) ;; 9 (prim2 (lambda (x y) (_field1-set! x y) y)) ;; 10 (prim2 (lambda (x y) (_field2-set! x y) y)) ;; 11 - (prim2 (lambda (x y) (boolean (eqv? x y)))) ;; 12 + (prim2 (lambda (x y) ;; 12 + (cond + ((symbol? x) + (boolean (or (symeq? x y) + (eqv? x y)))) + ((symbol? y) + (boolean (or (symeq? y x) + (eqv? x y)))) + (else + (boolean (eqv? x y)))))) (prim2 (lambda (x y) (boolean (< x y)))) ;; 13 (prim2 +) ;; 14 (prim2 -) ;; 15 @@ -438,13 +440,31 @@ (set! output-result x) (done-cb output-result output-buf))))) + (for-each (lambda (e) + (let ((sym (car e))) + (hashtable-set! globals sym (_string->uninterned-symbol + (symbol->string sym))))) + exports) + + ;; Enter primitives + (for-each (lambda (e) + (let ((sym (car e)) + (code (cadr e))) + (set-var "unused" sym + (_rib code _nil procedure-type)))) + primitives0) + + (hashtable-set! globals 'false _false) + (hashtable-set! globals 'true _true) + (hashtable-set! globals 'nil _nil) + ;; Start - (let ((x (decode))) - (run (_field2 (_field0 x)) ;; instruction stream of main procedure - (_rib 0 0 (_rib 5 0 0))) ;; primordial continuation = halt - (when (eq? not-yet output-result) - (done-cb #t output-buf)) - )) + + (run (_field2 (_field0 code)) ;; instruction stream of main procedure + (_rib 0 0 (_rib 6 0 0))) ;; primordial continuation = halt + (when (eq? not-yet output-result) + (done-cb #t output-buf)) + ) )