From 05590dd0fca4983f7b97b9024576ded4491af305 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 2 Sep 2009 20:41:56 -0400 Subject: [PATCH] Reworked the branch instructions of the VM, and changed code generation accordingly. --- comp.scm | 134 ++++++++++++++++++++++++++++++++++++++++++++++- dispatch.c | 87 ++++++++++++++++++++----------- encoding.scm | 166 +++++++++++++++++++++++++++++++++++++++++++++++++---------- picobit-vm.h | 12 +++-- 4 files changed, 337 insertions(+), 62 deletions(-) diff --git a/comp.scm b/comp.scm index d383837..250fe79 100644 --- a/comp.scm +++ b/comp.scm @@ -1,4 +1,4 @@ -;;;; File: "comp.scm", Time-stamp: <2006-05-08 16:04:37 feeley> +;;;; File: "comp.scm", Time-stamp: <2009-08-21 23:41:38 feeley> ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour ;;;; All Rights Reserved. @@ -1047,7 +1047,7 @@ (make-vector (vector-length bbs) 1) (vector-length bbs))))) -(define linearize +(define linearize-old (lambda (bbs) (let loop ((label (- (vector-length bbs) 1)) (lst '())) @@ -1080,6 +1080,136 @@ lst))) lst)))) +(define linearize + (lambda (bbs) + + (define rev-code '()) + + (define pos 0) + + (define (emit x) + (set! pos (+ pos 1)) + (set! rev-code (cons x rev-code))) + + (define todo (cons '() '())) + + (define dumped (make-vector (vector-length bbs) #f)) + + (define (get fallthrough-to-next?) + (if (pair? (cdr todo)) + (if fallthrough-to-next? + (let* ((label-pos (cadr todo)) + (label (car label-pos)) + (rest (cddr todo))) + (if (not (pair? rest)) + (set-car! todo todo)) + (set-cdr! todo rest) + label) + (let loop ((x (cdr todo)) (best-label-pos #f)) + #; + (if (pair? x) + (if (not (vector-ref dumped (car (car x)))) + (pp (car x)))) + (if (pair? x) + (loop (cdr x) + (if (vector-ref dumped (car (car x))) + best-label-pos + (if (or (not best-label-pos) + (> (cdr (car x)) (cdr best-label-pos))) + (car x) + best-label-pos))) + (if (pair? best-label-pos) + (car best-label-pos) + #f)))) + #f)) + + (define (next) + (let loop ((x (cdr todo))) + (if (pair? x) + (let* ((label-pos (car x)) + (label (car label-pos))) + (if (not (vector-ref dumped label)) + label + (loop (cdr x)))) + #f))) + + (define (schedule! label tail?) + (let ((label-pos (cons label pos))) + (if tail? + (let ((cell (cons label-pos '()))) + (set-cdr! (car todo) cell) + (set-car! todo cell)) + (let ((cell (cons label-pos (cdr todo)))) + (set-cdr! todo cell) + (if (eq? (car todo) todo) + (set-car! todo cell)))))) + + (define (dump) + (let loop ((fallthrough-to-next? #t)) + (let ((label (get fallthrough-to-next?))) + (if label + (if (not (vector-ref dumped label)) + (begin + (vector-set! dumped label #t) + (loop (dump-bb label))) + (loop fallthrough-to-next?)))))) + + (define (dump-bb label) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb)) + (jump (car rev-instrs)) + (opcode (car jump))) + (emit label) + (for-each + (lambda (instr) + (case (car instr) + ((closure call-toplevel) + (schedule! (cadr instr) #t))) + (emit instr)) + (reverse (cdr rev-instrs))) + (cond ((eq? opcode 'goto) + (schedule! (cadr jump) #f) + (if (not (equal? (cadr jump) (next))) + (begin + (emit jump) + #f) + #t)) + ((eq? opcode 'goto-if-false) + (schedule! (cadr jump) #f) + (schedule! (caddr jump) #f) + (cond ((equal? (caddr jump) (next)) + (emit (list 'goto-if-false (cadr jump))) + #t) + ((equal? (cadr jump) (next)) + (emit (list 'prim '#%not)) + (emit (list 'goto-if-false (caddr jump))) + #t) + (else + (emit (list 'goto-if-false (cadr jump))) + (emit (list 'goto (caddr jump))) + #f))) + (else + (case (car jump) + ((jump-toplevel) + (schedule! (cadr jump) #f) + ;; it is not correct to remove jump-toplevel when label is next + (if #t ;; (not (equal? (cadr jump) (next))) + (begin + (emit jump) + #f) + #t)) + (else + (emit jump) + #f)))))) + + (set-car! todo todo) ;; make fifo + + (schedule! 0 #f) + + (dump) + + (reverse rev-code))) + (define optimize-code (lambda (code) (let ((bbs (code->vector code))) diff --git a/dispatch.c b/dispatch.c index 9a2ce76..073a8ef 100644 --- a/dispatch.c +++ b/dispatch.c @@ -302,17 +302,24 @@ void interpreter () { FETCH_NEXT_BYTECODE(); - IF_TRACE(printf(" (closure 0x%04x)\n", (arg2 << 8) | bytecode)); + entry = (arg2 << 8) | bytecode; + + IF_TRACE(printf(" (closure 0x%04x)\n", entry)); arg3 = pop(); // env - entry = (arg2 << 8) | bytecode; + arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (entry >> 11), + entry >> 3, + ((entry & 0x07) <<5) | ((arg3 >> 8) & 0x1f), + arg3 & 0xff); - arg1 = +#if 0 + arg1 = // FOO remove alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3), ((arg2 & 0x07) << 5) | (bytecode >> 3), ((bytecode & 0x07) << 5) | ((arg3 & 0x1f00) >> 8), arg3 & 0xff); +#endif push_arg1(); @@ -321,14 +328,13 @@ void interpreter () { break; -#if 0 - case 5: // call-toplevel-short +#if 1 + case 5: // call-toplevel-rel8 FETCH_NEXT_BYTECODE(); // TODO the short version have a lot in common with the long ones, abstract ? - // TODO short instructions don't work at the moment - IF_TRACE(printf(" (call-toplevel-short 0x%04x)\n", - pc + bytecode + CODE_START)); - entry = pc + bytecode + CODE_START; + IF_TRACE(printf(" (call-toplevel-rel8 0x%04x)\n", pc + bytecode - 128)); + + entry = pc + bytecode - 128; arg1 = OBJ_NULL; build_env (rom_get (entry++)); @@ -341,13 +347,12 @@ void interpreter () { break; - case 6: // jump-toplevel-short + case 6: // jump-toplevel-rel8 FETCH_NEXT_BYTECODE(); - IF_TRACE(printf(" (jump-toplevel-short 0x%04x)\n", - pc + bytecode + CODE_START)); + IF_TRACE(printf(" (jump-toplevel-rel8 0x%04x)\n", pc + bytecode - 128)); - entry = pc + bytecode + CODE_START; + entry = pc + bytecode - 128; arg1 = OBJ_NULL; build_env (rom_get (entry++)); @@ -359,38 +364,41 @@ void interpreter () { break; - case 7: // goto-short + case 7: // goto-rel8 FETCH_NEXT_BYTECODE(); - IF_TRACE(printf(" (goto-short 0x%04x)\n", pc + bytecode + CODE_START)); + IF_TRACE(printf(" (goto-rel8 0x%04x)\n", pc + bytecode - 128)); - pc = pc + bytecode + CODE_START; + pc = pc + bytecode - 128; break; - case 8: // goto-if-false-short + case 8: // goto-if-false-rel8 FETCH_NEXT_BYTECODE(); - IF_TRACE(printf(" (goto-if-false-short 0x%04x)\n", - pc + bytecode + CODE_START)); + IF_TRACE(printf(" (goto-if-false-rel8 0x%04x)\n", pc + bytecode - 128)); if (pop() == OBJ_FALSE) - pc = pc + bytecode + CODE_START; + pc = pc + bytecode - 128; break; - case 9: // closure-short + /* #if 0 */ // FOO + + // FOO why does this not work? don't worry about it now. + + case 9: // closure-rel8 FETCH_NEXT_BYTECODE(); - IF_TRACE(printf(" (closure-short 0x%04x)\n", pc + bytecode)); + entry = pc + bytecode - 128; - arg3 = pop(); // env + IF_TRACE(printf(" (closure-rel8 0x%04x)\n", entry)); - entry = pc + bytecode; + arg3 = pop(); // env - arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (arg2 >> 3), - ((arg2 & 0x07) << 5) | (bytecode >> 3), - ((bytecode &0x07) <<5) |((arg3 &0x1f00) >>8), + arg1 = alloc_ram_cell_init (CLOSURE_FIELD0 | (entry >> 11), + entry >> 3, + ((entry & 0x07) << 5) | ((arg3 >> 8) & 0x1f), arg3 & 0xff); push_arg1(); @@ -398,6 +406,8 @@ void interpreter () { arg3 = OBJ_FALSE; break; + /* #endif */ // FOO + #endif #if 0 @@ -450,12 +460,31 @@ void interpreter () { goto dispatch; /*************************************************************************/ - case FREE1 : // FREE + + case JUMP_TOPLEVEL_REL4 : + + IF_TRACE(printf(" (jump-toplevel-rel4 0x%04x)\n", pc + (bytecode & 0x0f))); + + entry = pc + (bytecode & 0x0f); + arg1 = OBJ_NULL; + + build_env (rom_get (entry++)); + + env = arg1; + pc = entry; + + arg1 = OBJ_FALSE; goto dispatch; /*************************************************************************/ - case FREE2 : // FREE + + case GOTO_IF_FALSE_REL4 : + + IF_TRACE(printf(" (goto-if-false-rel4 0x%04x)\n", pc + (bytecode & 0x0f))); + + if (pop() == OBJ_FALSE) + pc = pc + (bytecode & 0x0f); goto dispatch; diff --git a/encoding.scm b/encoding.scm index 2751774..fe2228c 100644 --- a/encoding.scm +++ b/encoding.scm @@ -1,4 +1,4 @@ -;;;; File: "encoding.scm", Time-stamp: <2006-05-08 16:04:37 feeley> +;;;; File: "encoding.scm", Time-stamp: <2009-08-22 14:39:05 feeley> ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour ;;;; All Rights Reserved. @@ -213,34 +213,79 @@ (let ((constants (sort-constants constants)) (globals (sort-globals globals))) - (define (label-instr label opcode) + (define (label-instr label opcode-rel4 opcode-rel8 opcode-rel12 opcode-abs16 opcode-sym) +;;;;;;;;;;;;;;;;; (if (eq? opcode-sym 'goto) (pp (list 'goto label))) (asm-at-assembly ;; if the distance from pc to the label fits in a single byte, ;; a short instruction is used, containing a relative address ;; if not, the full 16-bit label is used -;;; (lambda (self) -;;; (let ((dist (- (asm-label-pos label) self))) -;;; (and (< dist 256) ;; TODO have this between -128 and 127 ? would be more flexible, I guess -;;; (> dist 0) -;;; 2))) -;;; (lambda (self) -;;; (asm-8 (+ opcode 5)) -;;; (asm-8 (- (asm-label-pos label) self))) - ;; TODO doesn't work at the moment - + (lambda (self) + (let ((dist (- (asm-label-pos label) (+ self 1)))) + (and opcode-rel4 + (<= 0 dist 15) ;; TODO go backwards too ? + 1))) + (lambda (self) + (let ((dist (- (asm-label-pos label) (+ self 1)))) + (if stats? + (let ((key (list '---rel-4bit opcode-sym))) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 (+ opcode-rel4 dist)))) + + (lambda (self) + (let ((dist (+ 128 (- (asm-label-pos label) (+ self 2))))) + (and opcode-rel8 + (<= 0 dist 255) + 2))) + (lambda (self) + (let ((dist (+ 128 (- (asm-label-pos label) (+ self 2))))) + (if stats? + (let ((key (list '---rel-8bit opcode-sym))) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 opcode-rel8) + (asm-8 dist))) + + (lambda (self) + (let ((dist (+ 2048 (- (asm-label-pos label) (+ self 2))))) + (and opcode-rel12 + (<= 0 dist 4095) + 2))) + (lambda (self) + (let ((dist (+ 2048 (- (asm-label-pos label) (+ self 2))))) + (if stats? + (let ((key (list '---rel-12bit opcode-sym))) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 (+ opcode-rel12 (quotient dist 256))) + (asm-8 (modulo dist 256)))) + (lambda (self) 3) (lambda (self) (let ((pos (- (asm-label-pos label) code-start))) - (asm-8 opcode) - (asm-8 (quotient pos 256)) - (asm-8 (modulo pos 256)))))) + (if stats? + (let ((key (list '---abs-16bit opcode-sym))) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 opcode-abs16) + (asm-8 (quotient pos 256)) + (asm-8 (modulo pos 256)))))) (define (push-constant n) (if (<= n 31) - (asm-8 (+ #x00 n)) (begin - (asm-8 (+ #x90 (quotient n 256))) + (if stats? + (let ((key '---push-constant-1byte)) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 (+ #x00 n))) + (begin + (if stats? + (let ((key '---push-constant-2bytes)) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 (+ #xa0 (quotient n 256))) (asm-8 (modulo n 256))))) (define (push-stack n) @@ -250,15 +295,35 @@ (define (push-global n) (if (<= n 15) - (asm-8 (+ #x40 n)) - (begin (asm-8 #x8e) - (asm-8 n)))) + (begin + (if stats? + (let ((key '---push-global-1byte)) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 (+ #x40 n))) + (begin + (if stats? + (let ((key '---push-global-2bytes)) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 #x8e) + (asm-8 n)))) (define (set-global n) (if (<= n 15) - (asm-8 (+ #x50 n)) - (begin (asm-8 #x8f) - (asm-8 n)))) + (begin + (if stats? + (let ((key '---set-global-1byte)) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 (+ #x50 n))) + (begin + (if stats? + (let ((key '---set-global-2bytes)) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1))))) + (asm-8 #x8f) + (asm-8 n)))) (define (call n) (if (> n 15) @@ -270,20 +335,48 @@ (compiler-error "call has too many arguments") (asm-8 (+ #x70 n)))) + (define optimize! #f);;;;;;;;;;;;;;;;;;;;; +; (define optimize! 0);;;;;;;;;;;;;;;;;;;;; + (define (call-toplevel label) - (label-instr label #x80)) + (label-instr label + #f ;; saves 36 (22) + #xb5 ;; saves 60, 78 (71) + #f ;; saves 150, 168 (161) + #xb0 + 'call-toplevel)) (define (jump-toplevel label) - (label-instr label #x81)) + (label-instr label + #x80 ;; saves 62 (62) + #xb6 ;; saves 45, 76 (76) + #f ;; saves 67, 98 (98) + #xb1 + 'jump-toplevel)) (define (goto label) - (label-instr label #x82)) + (label-instr label + #f ;; saves 0 (2) + #xb7 ;; saves 21, 21 (22) + #f ;; saves 30, 30 (31) + #xb2 + 'goto)) (define (goto-if-false label) - (label-instr label #x83)) + (label-instr label + #x90 ;; saves 54 (44) + #xb8 ;; saves 83, 110 (105) + #f ;; saves 109, 136 (131) + #xb3 + 'goto-if-false)) (define (closure label) - (label-instr label #x84)) + (label-instr label + #f ;; saves 50 (48) + #xb9 ;; #f;; does not work!!! #xb9 ;; saves 27, 52 (51) FOO + #f ;; saves 34, 59 (58) + #xb4 + 'closure)) (define (prim n) (asm-8 (+ #xc0 n))) @@ -346,6 +439,9 @@ (define big-endian? #f) + (define stats? #t) + (define instr-table (make-table)) + (asm-begin! code-start #f) (asm-8 #xfb) @@ -415,10 +511,18 @@ (compiler-error "unknown object type" obj))))) constants) + ;;(pp code);;;;;;;;;;;; + (let loop2 ((lst code)) (if (pair? lst) (let ((instr (car lst))) + (if stats? + (if (not (number? instr)) + (let ((key (car instr))) + (let ((n (table-ref instr-table key 0))) + (table-set! instr-table key (+ n 1)))))) + (cond ((number? instr) (let ((label (cdr (assq instr labels)))) (asm-label label))) @@ -544,6 +648,12 @@ (asm-assemble) + (if stats? + (pretty-print + (sort-list (table->list instr-table) + (lambda (x y) (> (cdr x) (cdr y)))))) + +;;;;;;;;; (asm-display-listing ##stdout-port);;;;;;;;;;;;; (asm-write-hex-file hex-filename) (asm-end!)))))) diff --git a/picobit-vm.h b/picobit-vm.h index 4d5989f..3bdd3ee 100644 --- a/picobit-vm.h +++ b/picobit-vm.h @@ -685,11 +685,17 @@ void prim_send_packet_from_u8vector (); #define SET_GLOBAL 0x5 #define CALL 0x6 #define JUMP 0x7 +#if 1 +#define JUMP_TOPLEVEL_REL4 0x8 +#define GOTO_IF_FALSE_REL4 0x9 +#define PUSH_CONSTANT_LONG 0xa +#define LABEL_INSTR 0xb +#else +#define JUMP_TOPLEVEL_REL4 0xa +#define GOTO_IF_FALSE_REL4 0xb #define LABEL_INSTR 0x8 #define PUSH_CONSTANT_LONG 0x9 - -#define FREE1 0xa -#define FREE2 0xb +#endif #define PRIM1 0xc #define PRIM2 0xd -- 2.11.4.GIT