Reworked the branch instructions of the VM, and changed code
authorVincent St-Amour <stamourv@iro.umontreal.ca>
Thu, 3 Sep 2009 00:41:56 +0000 (2 20:41 -0400)
committerVincent St-Amour <stamourv@iro.umontreal.ca>
Thu, 3 Sep 2009 00:41:56 +0000 (2 20:41 -0400)
generation accordingly.

comp.scm
dispatch.c
encoding.scm
picobit-vm.h

index d383837..250fe79 100644 (file)
--- 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.
                        (make-vector (vector-length bbs) 1)
                        (vector-length bbs)))))
 
-(define linearize
+(define linearize-old
   (lambda (bbs)
     (let loop ((label (- (vector-length bbs) 1))
                (lst '()))
                    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)))
index 9a2ce76..073a8ef 100644 (file)
@@ -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;
 
index 2751774..fe2228c 100644 (file)
@@ -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.
           (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)
 
             (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)
                   (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)))
            
             (define big-endian? #f)
 
+            (define stats? #t)
+            (define instr-table (make-table))
+
             (asm-begin! code-start #f)
 
             (asm-8 #xfb)
                         (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)))
 
             (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!))))))
index 4d5989f..3bdd3ee 100644 (file)
@@ -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