Add assembler

scmvm/assembler.scm

@@ -0,0 +1,49 @@
+(define-module (scmvm assembler)
+  #:use-module (srfi srfi-1)
+  #:use-module (scmvm vm)
+  #:use-module (rnrs bytevectors)
+  #:use-module ((scheme base)
+                #:select (write-u8 write-bytevector))
+  #:export (assemble))
+
+(define (lookup-instruction inst)
+  (define inst-obj (assq inst *instruction-set*))
+  (if inst-obj
+      inst-obj
+      (error (format #f "could not find instruction ~a" inst))))
+
+(define (instruction-size inst)
+  (case (instruction-type (lookup-instruction inst))
+    [(i j) 5]
+    [(o)   1]))
+
+(define instruction? pair?)
+(define label? (compose not instruction?))
+
+(define (find-labels inst-seq n)
+  (cond
+   [(null? inst-seq) '()]
+   [(label? (car inst-seq))
+    (acons (car inst-seq) n (find-labels (cdr inst-seq) n))]
+   [else
+    (find-labels (cdr inst-seq) (+ n (instruction-size (caar inst-seq))))]))
+
+(define (write-word word)
+  (define bv (make-bytevector 4))
+  (bytevector-s32-native-set! bv 0 word)
+  (write-bytevector bv))
+
+(define (assemble inst-seq)
+  (define labels (find-labels inst-seq 0))
+  (let loop ([seq inst-seq])
+    (cond
+     [(null? seq) '()]
+     [(label? (car seq)) (loop (cdr seq))]
+     [else
+      (let* [(inst (car seq))
+             (inst-obj (lookup-instruction (car inst)))]
+        (write-u8 (instruction-code inst-obj))
+        (case (instruction-type inst-obj)
+          [(i) (write-word (cadr inst))]
+          [(j) (write-word (assq-ref labels (cadr inst)))])
+        (loop (cdr seq)))])))

scmvm/vm.scm

@@ -2,8 +2,10 @@
   #:use-module ((scheme base)
                 #:select (read-u8 read-bytevector))
   #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
-  #:export (make-vm run-vm vm-memory-ref vm-memory-set!))
+  #:export (make-vm run-vm vm-memory-ref vm-memory-set!
+            *instruction-set* instruction-type instruction-code))
 
 ;;; Data Structures
 (define *stack-size* 1000)
@@ -78,31 +80,35 @@
     (bytevector-s32-ref bv 0 (native-endianness))))
 
 ;;; Program execution
-(define *opcodes*
+(define *instruction-set*
-  '((#x01 . push)
+  '((push   #x01 i)
-    (#x02 . pop)
+    (pop    #x02 o)
-    (#x03 . store)
+    (store  #x03 i)
-    (#x04 . load)
+    (load   #x04 i)
-    (#x05 . +)
+    (+      #x05 o)
-    (#x06 . -)
+    (-      #x06 o)
-    (#x07 . and)
+    (and    #x07 o)
-    (#x08 . or)
+    (or     #x08 o)
-    (#x09 . nand)
+    (nand   #x09 o)
-    (#x0a . nor)
+    (nor    #x0a o)
-    (#x0b . xor)
+    (xor    #x0b o)
-    (#x0c . if)
+    (if     #x0c j)
-    (#x0d . call)
+    (call   #x0d j)
-    (#x0e . return)
+    (return #x0e o)
-    (#x0f . >R)
+    (>R     #x0f o)
-    (#x10 . R>)
+    (R>     #x10 o)
-    (#x11 . =)
+    (=      #x11 o)
-    (#x12 . >)
+    (>      #x12 o)
-    (#x13 . <)
+    (<      #x13 o)
-    (#x14 . dup)
+    (dup    #x14 o)
-    (#x15 . swap)
+    (swap   #x15 o)
-    (#x16 . jmp)))
+    (jmp    #x16 j)))
 
-(define op-lookup (cute assq-ref *opcodes* <>))
+(define instruction-code cadr)
+(define instruction-type caddr)
+
+(define (op-lookup code)
+  (car (find (lambda (x) (= (instruction-code x) code)) *instruction-set*)))
 
 (define (binop-lookup op)
   (case (op-lookup op)

tests.scm

@@ -1,19 +1,64 @@
-(use-modules (d- test))
+(use-modules (d- test)
-
+             (scmvm assembler)
-
+             (scmvm vm)
-;;; VM tests
-(use-modules (scmvm vm)
              (rnrs bytevectors)
-             (rnrs io ports))
+             (rnrs io ports)
+             ((scheme base)
+              #:select (open-output-bytevector get-output-bytevector)))
+
+;;; Data
+(define adder-program-asm
+  '((push 1)
+    (push 2)
+    (+)
+    (store #x01)))
 
-(define adder-program
+(define fib-program-asm
+  '(  (load 1)
+      (call fib)
+      (jmp cleanup)
+    fib
+      (dup)
+      (push 0)
+      (=)
+      (if not0)
+      (pop)
+      (pop)
+      (push 0)
+      (return)
+    not0
+      (pop)
+      (dup)
+      (push 1)
+      (=)
+      (if not1)
+      (pop)
+      (pop)
+      (push 1)
+      (return)
+    not1
+      (pop)
+      (push 1)
+      (-)
+      (dup)
+      (call fib)
+      (swap)
+      (push 1)
+      (-)
+      (call fib)
+      (+)
+      (return)
+    cleanup
+      (store #x1)))
+
+(define adder-program-bytecode
   #vu8(#x01 1 0 0 0 ; Push value "1"
        #x01 2 0 0 0 ; Push value "2"
        #x05         ; Perform "+"
        #x03 1 0 0 0 ; Store the value to memory address 1
        ))
 
-(define fib-program
+(define fib-program-bytecode
   #vu8(#x04 1  0 0 0 ; 0  load "n" from memory address 0x01
        #x0d 15 0 0 0 ; 5  call fib procedure
        #x16 83 0 0 0 ; 10 jump to cleanup
@@ -52,15 +97,27 @@
        #x03 1  0 0 0 ; 83 store fib(n) to memory address 0x01
        ))
 
-(define-test-suite "VM"
+
+;;; Tests
+(define-test-suite "assembler"
+  (define-test "adder"
+    (define out (open-output-bytevector))
+    (with-output-to-port out (lambda () (assemble adder-program-asm)))
+    (assert-equal adder-program-bytecode (get-output-bytevector out)))
+  (define-test "fib"
+    (define out (open-output-bytevector))
+    (with-output-to-port out (lambda () (assemble fib-program-asm)))
+    (assert-equal fib-program-bytecode (get-output-bytevector out))))
+
+(define-test-suite "vm"
   (define-test "adder"
     (define my-vm (make-vm))
-    (define my-program (open-bytevector-input-port adder-program))
+    (define my-program (open-bytevector-input-port adder-program-bytecode))
     (run-vm my-vm my-program)
     (assert-equal 3 (vm-memory-ref my-vm 1)))
   (define-test "fib"
     (define my-vm (make-vm))
-    (vm-memory-set! my-vm 1 6)
+    (vm-memory-set! my-vm 1 10)
-    (define my-program (open-bytevector-input-port fib-program))
+    (define my-program (open-bytevector-input-port fib-program-bytecode))
     (run-vm my-vm my-program)
-    (assert-equal 8 (vm-memory-ref my-vm 1))))
+    (assert-equal 55 (vm-memory-ref my-vm 1))))