(define-module (scmvm vm)
  #:use-module ((scheme base)
                #:select (read-u8 read-bytevector))
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-43)
  #:use-module (ice-9 format)
  #:use-module (scmvm util stack)
  #:export ((make-vm* . make-vm) run-vm
    	    vm-memory-ref vm-memory-byte-ref vm-memory-set! vm-memory vm-load-program!
	    vm-data-stack vm-ret-stack
	    vm-debugger vm-debugger-set!
	    vm-pc vm-pc-set!
            vm-instruction-set
            instruction-lookup instruction-name instruction-code
	    forth-instruction-set))

;;; IO
(define *memory-size* 2048)

(define* (make-ram #:optional (memory-size *memory-size*))
  (make-bytevector memory-size #x00))

(define (read-word)
  "Read the next 32-bit value from (current-input-port)"
  (let ([bv (read-bytevector 4)])
    (bytevector-s32-ref bv 0 (native-endianness))))

;;; Instructions
(define-syntax define-instruction-set
  (syntax-rules (define-instruction)
    [(_ set-name (define-instruction (name opcode) impl ...) ...)
     (define (set-name dispatch)
       (case dispatch
         [(lookup)
          (lambda (lookup)
            (case lookup
              [(name) '(name opcode)] ...
              [else #f]))]
         [(call)
          (lambda (op)
            (case op
              [(opcode) impl ...] ...))]))]))

(define (instruction-lookup isa name)
  ((isa 'lookup) name))

(define (instruction-set-call isa op)
  ((isa 'call) op))

(define instruction-name car)
(define instruction-code cadr)

(define-instruction-set forth-instruction-set
  (define-instruction (push #x01)
    (stack-push (*data-stack*) (fetch-word!)))
  (define-instruction (! #x02)
    (let ([addr (stack-pop (*data-stack*))]
          [v (stack-pop (*data-stack*))])
      (ram-word-set! addr v)))
  (define-instruction (@ #x03)
    (let* ([addr (stack-pop (*data-stack*))]
           [v (ram-word-ref addr)])
      (stack-push (*data-stack*) v)))
  (define-instruction (+ #x04)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) (+ v1 v2))))
  (define-instruction (- #x05)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) (- v1 v2))))
  (define-instruction (and #x06)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) (logand v1 v2))))
  (define-instruction (or #x07)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) (logior v1 v2))))
  (define-instruction (nand #x08)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) (if (zero? (logand v1 v2)) 1 0))))
  (define-instruction (nor #x09)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) (if (zero? (logior v1 v2)) 1 0))))
  (define-instruction (xor #x0a)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) (logxor v1 v2))))
  (define-instruction (= #x0b)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (if (= v1 v2)
          (stack-push (*data-stack*) 1)
          (stack-push (*data-stack*) 0))))
  (define-instruction (> #x0c)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (if (> v1 v2)
          (stack-push (*data-stack*) 1)
          (stack-push (*data-stack*) 0))))
  (define-instruction (< #x0d)
    (let ([v2 (stack-pop (*data-stack*))]
          [v1 (stack-pop (*data-stack*))])
      (if (< v1 v2)
          (stack-push (*data-stack*) 1)
          (stack-push (*data-stack*) 0))))
  (define-instruction (jmp #x0e)
    (jump! (stack-pop (*data-stack*))))
  (define-instruction (branch #x0f)
    (let* ([addr (stack-pop (*data-stack*))]
           [test (stack-pop (*data-stack*))])
      (when (zero? test)
        (jump! addr))))
  (define-instruction (call #x10)
    (let ([addr (stack-pop (*data-stack*))])
      (stack-push (*ret-stack*) (vm-pc (*vm*)))
      (jump! addr)))
  (define-instruction (return #x11)
    (jump! (stack-pop (*ret-stack*))))
  (define-instruction (>R #x12)
    (stack-push (*ret-stack*) (stack-pop (*data-stack*))))
  (define-instruction (R> #x13)
    (stack-push (*data-stack*) (stack-pop (*ret-stack*))))
  (define-instruction (drop #x14)
    (stack-pop (*data-stack*)))
  (define-instruction (nip #x15)
    (let ([v (stack-pop (*data-stack*))])
      (stack-pop (*data-stack*))
      (stack-push (*data-stack*) v)))
  (define-instruction (dup #x16)
    (stack-push (*data-stack*) (stack-peek (*data-stack*))))
  (define-instruction (swap #x17)
    (stack-swap (*data-stack*)))
  (define-instruction (rot #x18)
    (let* ([a (stack-pop (*data-stack*))]
           [b (stack-pop (*data-stack*))]
           [c (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) a)
      (stack-push (*data-stack*) c)
      (stack-push (*data-stack*) b)))
  (define-instruction (over #x19)
    (let* ([a (stack-pop (*data-stack*))]
           [b (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) b)
      (stack-push (*data-stack*) a)
      (stack-push (*data-stack*) b)))
  (define-instruction (not #x1a)
    (let ([a (stack-pop (*data-stack*))])
      (stack-push (*data-stack*) (if (zero? a) 1 0))))
  (define-instruction (set! #x1b)
    ;; use let* to induce an order of evaluation
    (let* ([idx (stack-pop (*data-stack*))]
           [obj (stack-pop (*data-stack*))])
      (stack-set! (*data-stack*) idx obj)))
  (define-instruction (bye #xff)
    (*vm-exit* #t)))


;;; VM
(define-record-type <vm>
  (make-vm data-stack ret-stack memory pc debugger instruction-set)
  vm?
  (data-stack vm-data-stack)
  (ret-stack vm-ret-stack)
  (memory vm-memory)
  (pc vm-pc vm-pc-set!)
  (debugger vm-debugger vm-debugger-set!)
  (instruction-set vm-instruction-set vm-instruction-set-set!))

(define* (make-vm* instruction-set #:key stack-size memory-size debugger)
  "Create a fresh VM, with optional stack and memory sizes"
  (define data-stack (if stack-size (make-stack stack-size) (make-stack)))
  (define ret-stack (if stack-size (make-stack stack-size) (make-stack)))
  (define ram (if memory-size (make-ram memory-size) (make-ram)))
  (define isa (if instruction-set instruction-set forth-instruction-set))
  (make-vm data-stack ret-stack ram 1 debugger isa))

(define *vm* (make-parameter #f))
(define *data-stack* (make-parameter #f))
(define *ret-stack* (make-parameter #f))
(define *vm-exit* (make-parameter #f))

(define (ram-word-ref k)
  (vm-memory-ref (*vm*) k))

(define (ram-byte-ref k)
  (vm-memory-byte-ref (*vm*) k))

(define (ram-word-set! k v)
  (vm-memory-set! (*vm*) k v))

(define (jump! x)
  (vm-pc-set! (*vm*) (logand #x2fffffff x)))

(define (fetch-byte!)
  (let* ([vm (*vm*)]
         [byte (ram-byte-ref (vm-pc vm))])
    (vm-pc-set! vm (+ (vm-pc vm) 1))
    byte))

(define (fetch-word!)
  (let* ([vm (*vm*)]
         [word (ram-word-ref (vm-pc vm))])
    (vm-pc-set! vm (+ (vm-pc vm) 4))
    word))

;;; Execution
(define (run-vm vm)
  "Begin execution at pc"
  (parameterize ([*vm* vm]
                 [*data-stack* (vm-data-stack vm)]
                 [*ret-stack* (vm-ret-stack vm)]
                 [*vm-exit* #f])
    (define debugger (vm-debugger vm))
    (let lp () 
      (when debugger
        (debugger))
      (define op (fetch-byte!))
      (instruction-set-call (vm-instruction-set (*vm*)) op)
      (unless (*vm-exit*) (lp)))))

(define (vm-memory-ref vm k)
  (if (< k 1)
      (error "null memory read")
      (bytevector-s32-native-ref (vm-memory vm) (1- k))))
(define (vm-memory-byte-ref vm k)
  (if (< k 1)
      (error "null memory read")
      (bytevector-u8-ref (vm-memory vm) (1- k))))
(define (vm-memory-set! vm k v)
  (if (< k 1)
      (error "null memory write")
      (bytevector-s32-native-set! (vm-memory vm) (1- k) v)))

(define (vm-load-program! vm prgm)
  "Loads the bytevector into the vm, starting at memory address 1"
  (let ([ram (vm-memory vm)])
    (bytevector-copy! prgm 0
                      ram 0
                      (bytevector-length prgm))))