An emulator for a simple cpu.

vm-emulator.rkt

(define registers (vector 0 0 0 0 0 0 0 0))
 
(define memory (make-vector 65536))
 
(define pc 0)
 
(define (load-program instructions)
  (define (recur cnt rem)
    (if (null? rem)
        #t
        (begin (vector-set! memory cnt (car rem))
               (recur (+ 1 cnt) (cdr rem)))))
  (recur 0 instructions))
 
(define stack '())
 
(define (branch-pc inc)
  (set! pc (+ pc inc)))
 
(define (reg-ref reg-name)
  (case reg-name
    [(a) (vector-ref registers 0)]
    [(b) (vector-ref registers 1)]
    [(c) (vector-ref registers 2)]
    [(d) (vector-ref registers 3)]
    [(e) (vector-ref registers 4)]
    [(f) (vector-ref registers 5)]
    [(g) (vector-ref registers 6)]
    [(h) (vector-ref registers 7)]))
 
(define (reg-set reg-name value)
  (case reg-name
    [(a) (vector-set! registers 0 value)]
    [(b) (vector-set! registers 1 value)]
    [(c) (vector-set! registers 2 value)]
    [(d) (vector-set! registers 3 value)]
    [(e) (vector-set! registers 4 value)]
    [(f) (vector-set! registers 5 value)]
    [(g) (vector-set! registers 6 value)]
    [(h) (vector-set! registers 7 value)]))
 
(define (mem-ref addr)
  (vector-ref memory addr))
 
(define (mem-set addr val)
  (vector-set! memory addr))
 
(define (execute-instruction instruction)
 
  (display instruction)
  (display "\n")
 
  (if (symbol? instruction)
      (begin (set! pc (+ 1 pc))
             #t)
      (let* ((opcode (first instruction))
               (operands (rest instruction))
               (res
               
                (case opcode
                 
                  ;; jump instructions
                  ;; go immediate
                  [(go) (set! pc (- (first operands) 1))]
                  ;; go to location in register
                  [(gor) (set! pc (mem-ref (first operands)))]
                  ;; go to location in memory
                  [(gom) (set! pc (mem-ref (first operands)))]
                 
                  ;; branch instuctions
                  ;; branch if immediate is not 0
                  [(binez) (when (not (= 0 (first operands))) (branch-pc 1))]
                  ;; branch if register not equal 0
                  [(brnez) (when (not (= 0 (reg-ref (first operands)))) (branch-pc 1))]
                  ;; branch if register equal 0
                  [(brez) (when (= 0 (reg-ref (first operands))) (branch-pc 1))]
                  [(breo) (when (= 1 (reg-ref (first operands))) (branch-pc 1))]
                 
                  ;; load/store instructions  - dest src
                 
                  ;; load reg immediate  - register - immediate value
                  [(ldri) (reg-set (first operands) (second operands))]  
                  ;; load reg from register
                  [(ldrr) (reg-set (first operands) (reg-ref (second operands)))]
                  ;; load reg from memory
                  [(ldrm) (reg-set (first operands) (mem-ref (second operands)))]
                  ;; set memory from register
                  [(smr) (mem-set (first operands) (reg-ref (second operands)))]
                  ;; set memory from immediate
                  [(smi) (mem-set (first operands) (second operands))]
                  ;; set memory from memory
                  [(smm) (mem-set (first operands) (mem-ref (second operands)))]
                 
                  ;; stack instructions
                 
                  ;; pop stack
                  [(pop) (set! stack (rest stack))]
                  ;; pop stack into register
                  [(popr) (begin (reg-set (first operands) (first stack)) (set! stack (rest stack)))]
                  ;; pop stack into memory
                  [(popm) (begin (mem-set (first operands) (first stack)) (set! stack (rest stack)))]
                 
                  ;; push stack immediate
                  [(pshi) (set! stack (cons (first operands) stack))]
                  ;; push stack register
                  [(pshr) (set! stack (cons (reg-ref (first operands)) stack))]
                  ;; push stack memory
                  [(pshm) (set! stack (cons (mem-ref (first operands)) stack))]
                 
                  ;; arithmetic instructions  dest src
                 
                  ;; register <- reg + reg
                  [(addrr) (reg-set (first operands) (+ (reg-ref (second operands)) (reg-ref (third operands))))]
                  ;; register <- reg + imm
                  [(addri) (reg-set (first operands) (+ (reg-ref (second operands)) (third operands)))]
                 
                  ;; register <- reg - reg
                  [(subrr) (reg-set (first operands) (- (reg-ref (second operands)) (reg-ref (third operands))))]
                  ;; register <- reg - imm
                  [(subri) (reg-set (first operands) (- (reg-ref (second operands)) (third operands)))]
                  ;; register <- imm - reg
                  [(subir) (reg-set (first operands) (- (third operands) (reg-ref (second operands))))]
                 
                  ;; print reg
                  [(prtr) (display (reg-ref (car operands)))]
                 
                  ;; half
                  [(halt) 'halt]
                  [else  (error "unknown opcode ~a" opcode)])))
          (set! pc (+ 1 pc))
          res)))
               
(define (execute-cycle)
  (let ((res (execute-instruction (vector-ref memory pc))))
    res))
 
(define (run-vm program)
  (let ((program (replace-labels program)))
    (set! memory (make-vector 65536))
    (load-program program)
    (set! pc 0)
    (set! stack '())
    (define (run-instruction)
      (if (equal? 'halt (execute-cycle))
          (print 'halted)
          (run-instruction)))
    (run-instruction)))
 
 
;; gets addresses of labels
(define (extract-labels program)
  (define (recur cnt rem labels)
    (if (null? rem)
        labels
        (if (symbol? (car rem))
            (recur cnt (cdr rem) (cons (list (car rem) cnt)
                                       labels))
            (recur (+ 1 cnt) (cdr rem) labels))))
  (recur 0 program '()))
 
;; replaces labels with addresses
(define (replace-labels program)
  (let ((labels (extract-labels program)))
  (define (recur rem)
    (cond
      ((null? rem) '())
      ((symbol? (car rem)) (recur (cdr rem)))
      ((and (equal? 'go (caar rem)) (not (number? (cadar rem))))
       (cons `(go ,(cadr (assoc (cadar rem) labels)))
             (recur (cdr rem))))
      (else (cons (car rem) (recur (cdr rem))))))      
  (recur program)))
 
;; prints the first nth fibonacci numbers
(define (fib-program number)
  (run-vm
  `((ldri a ,number) ;; load count into reg a
    (ldri b ,0)
    (ldri c ,1)
    start
    (brnez a)        ;; if a = 0
    (go end)         ;; go to end
    recur
    (prtr b)
    (subri a a 1)    ;; subtract 1 from a
    (ldrr d b)
    (ldrr e c)
    (ldrr b c)
    (addrr c d e)
    (go start)
    end
    (prtr b)
    (halt))))
 
(fib-program 8)
-> 0
-> 1
-> 1
-> 2
-> 3
-> 5
-> 8
-> 13
-> 21
'halted
 
;; multiplies a and b
(define (mult-program a b)
  (run-vm
   `((ldri a ,a)
     (ldri c ,a)
     (ldri b ,b)
     start
     (breo b)
     (go recur)
     (go end)
     recur
     (addrr a a c)
     (subri b b 1)
     (prtr b)
     (go start)
     end
     (prtr a)
     (halt))))
 
(mult-program 4 4)
-> 16