749 lines
24 KiB
Racket
749 lines
24 KiB
Racket
#lang typed/racket
|
|
;;;
|
|
;;; The Rosetta Code Virtual Machine, in Typed Racket.
|
|
;;;
|
|
;;; Migrated from the Common Lisp.
|
|
;;;
|
|
|
|
;;; Yes, I could compute how much memory is needed, or I could assume
|
|
;;; that the instructions are in address order. However, for *this*
|
|
;;; implementation I am going to use a large fixed-size memory and use
|
|
;;; the address fields of instructions to place the instructions.
|
|
(: executable-memory-size Positive-Fixnum)
|
|
(define executable-memory-size 65536)
|
|
|
|
;;; Similarly, I am going to have fixed size data and stack memory.
|
|
(: data-memory-size Positive-Fixnum)
|
|
(define data-memory-size 2048)
|
|
(: stack-memory-size Positive-Fixnum)
|
|
(define stack-memory-size 2048)
|
|
|
|
;;; And so I am going to have specialized types for the different
|
|
;;; kinds of memory the platform contains. Also for its "word" and
|
|
;;; register types.
|
|
(define-type Word Nonnegative-Fixnum)
|
|
(define-type Register (Boxof Word))
|
|
(define-type Executable-Memory (Mutable-Vectorof Byte))
|
|
(define-type Data-Memory (Mutable-Vectorof Word))
|
|
(define-type Stack-Memory (Mutable-Vectorof Word))
|
|
|
|
(define re-blank-line #px"^\\s*$")
|
|
(define re-parse-instr-1 #px"^\\s*(\\d+)\\s*(.*\\S)")
|
|
(define re-parse-instr-2 #px"(?i:^(\\S+)\\s*(.*))")
|
|
(define re-parse-instr-3 #px"^[[(]?([0-9-]+)")
|
|
(define re-header
|
|
#px"(?i:^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+))")
|
|
(define re-leading-spaces #px"^\\s*")
|
|
|
|
(define opcode-names
|
|
'("halt"
|
|
"add"
|
|
"sub"
|
|
"mul"
|
|
"div"
|
|
"mod"
|
|
"lt"
|
|
"gt"
|
|
"le"
|
|
"ge"
|
|
"eq"
|
|
"ne"
|
|
"and"
|
|
"or"
|
|
"neg"
|
|
"not"
|
|
"prtc"
|
|
"prti"
|
|
"prts"
|
|
"fetch"
|
|
"store"
|
|
"push"
|
|
"jmp"
|
|
"jz"))
|
|
|
|
(: blank-line? (String -> Boolean))
|
|
(define (blank-line? s)
|
|
(not (not (regexp-match re-blank-line s))))
|
|
|
|
(: opcode-from-name (String -> Byte))
|
|
(define (opcode-from-name s)
|
|
(let ((i (index-of opcode-names s)))
|
|
(assert i)
|
|
(cast i Byte)))
|
|
|
|
(: create-executable-memory (-> Executable-Memory))
|
|
(define (create-executable-memory)
|
|
(make-vector executable-memory-size (opcode-from-name "halt")))
|
|
|
|
(: create-data-memory (-> Data-Memory))
|
|
(define (create-data-memory)
|
|
(make-vector data-memory-size 0))
|
|
|
|
(: create-stack-memory (-> Stack-Memory))
|
|
(define (create-stack-memory)
|
|
(make-vector stack-memory-size 0))
|
|
|
|
(: create-register (-> Register))
|
|
(define (create-register)
|
|
(box 0))
|
|
|
|
(struct machine
|
|
((sp : Register) ; Stack pointer.
|
|
(ip : Register) ; Instruction pointer (that is, program counter).
|
|
(code : Executable-Memory)
|
|
(data : Data-Memory)
|
|
(stack : Stack-Memory)
|
|
(strings : (Immutable-Vectorof String))
|
|
(output : Output-Port))
|
|
#:type-name Machine
|
|
#:constructor-name %make-machine)
|
|
|
|
(: make-machine ((Immutable-Vectorof String) Output-Port -> Machine))
|
|
(define (make-machine strings outf)
|
|
(%make-machine (create-register)
|
|
(create-register)
|
|
(create-executable-memory)
|
|
(create-data-memory)
|
|
(create-stack-memory)
|
|
strings
|
|
outf))
|
|
|
|
(define-type Instruction-Data (List Word Byte (U False Word)))
|
|
|
|
(: insert-instruction (Executable-Memory Instruction-Data -> Void))
|
|
(define (insert-instruction memory instr)
|
|
(void
|
|
(match instr
|
|
((list address opcode arg)
|
|
(let ((instr-size (if arg 5 1)))
|
|
(unless (<= (+ address instr-size) executable-memory-size)
|
|
(raise-user-error
|
|
"the VM's executable memory size is exceeded"))
|
|
(vector-set! memory address opcode)
|
|
(when arg
|
|
;; Big-endian order.
|
|
(vector-set! memory (+ address 1)
|
|
(bitwise-and (arithmetic-shift arg -24) #xFF))
|
|
(vector-set! memory (+ address 2)
|
|
(bitwise-and (arithmetic-shift arg -16) #xFF))
|
|
(vector-set! memory (+ address 3)
|
|
(bitwise-and (arithmetic-shift arg -8) #xFF))
|
|
(vector-set! memory (+ address 4)
|
|
(bitwise-and arg #xFF))))))))
|
|
|
|
(: load-executable-memory (Executable-Memory
|
|
(Listof Instruction-Data) ->
|
|
Void))
|
|
(define (load-executable-memory memory instr-lst)
|
|
(let loop ((p instr-lst))
|
|
(if (null? p)
|
|
(void)
|
|
(let ((instr (car p)))
|
|
(insert-instruction memory (car p))
|
|
(loop (cdr p))))))
|
|
|
|
(: number->word (Number -> Word))
|
|
(define (number->word n)
|
|
(cast (bitwise-and (cast n Integer) #xFFFFFFFF) Word))
|
|
|
|
(: string->word (String -> Word))
|
|
(define (string->word s)
|
|
(let ((n (string->number s)))
|
|
(assert (number? n))
|
|
(number->word n)))
|
|
|
|
(: parse-instruction (String -> (U False Instruction-Data)))
|
|
(define (parse-instruction s)
|
|
(and (not (blank-line? s))
|
|
(let* ((strings (cast (regexp-match re-parse-instr-1 s)
|
|
(Listof String)))
|
|
(address (cast (string->number (second strings))
|
|
Word))
|
|
(split (cast (regexp-match re-parse-instr-2
|
|
(third strings))
|
|
(Listof String)))
|
|
(opcode-name (string-downcase (second split)))
|
|
(opcode (opcode-from-name opcode-name))
|
|
(arguments (third split))
|
|
(has-arg? (match opcode-name
|
|
((or "fetch" "store" "push" "jmp" "jz") #t)
|
|
(_ #f))))
|
|
(if has-arg?
|
|
(let* ((argstr-lst
|
|
(cast (regexp-match re-parse-instr-3 arguments)
|
|
(Listof String)))
|
|
(argstr (second argstr-lst))
|
|
(arg (string->word argstr)))
|
|
`(,address ,opcode ,arg))
|
|
`(,address ,opcode #f)))))
|
|
|
|
(: read-instructions (Input-Port -> (Listof Instruction-Data)))
|
|
(define (read-instructions inpf)
|
|
(let loop ((line (read-line inpf))
|
|
(lst (cast '() (Listof Instruction-Data))))
|
|
(if (eof-object? line)
|
|
(reverse lst)
|
|
(let ((instr (parse-instruction line)))
|
|
(loop (read-line inpf)
|
|
(if instr
|
|
(cons instr lst)
|
|
lst))))))
|
|
|
|
(: read-datasize-and-strings-count (Input-Port -> (Values Word Word)))
|
|
(define (read-datasize-and-strings-count inpf)
|
|
(let ((line (read-line inpf)))
|
|
(unless (string? line)
|
|
(raise-user-error "empty input"))
|
|
;; This is a permissive implementation.
|
|
(let* ((strings (cast (regexp-match re-header line)
|
|
(Listof String)))
|
|
(datasize (string->word (second strings)))
|
|
(strings-count (string->word (third strings))))
|
|
(values datasize strings-count))))
|
|
|
|
(: parse-string-literal (String -> String))
|
|
(define (parse-string-literal s)
|
|
;; This is a permissive implementation, but only in that it skips
|
|
;; any leading space. It does not check carefully for outright
|
|
;; mistakes.
|
|
(let* ((s (regexp-replace re-leading-spaces s ""))
|
|
(quote-mark (string-ref s 0)))
|
|
(let loop ((i 1)
|
|
(lst (cast '() (Listof Char))))
|
|
(if (char=? (string-ref s i) quote-mark)
|
|
(list->string (reverse lst))
|
|
(let ((c (string-ref s i)))
|
|
(if (char=? c #\\)
|
|
(let ((c0 (match (string-ref s (+ i 1))
|
|
(#\n #\newline)
|
|
(c1 c1))))
|
|
(loop (+ i 2) (cons c0 lst)))
|
|
(loop (+ i 1) (cons c lst))))))))
|
|
|
|
(: read-string-literals (Input-Port Word -> (Listof String)))
|
|
(define (read-string-literals inpf strings-count)
|
|
(for/list ((i (in-range strings-count)))
|
|
(let ((line (read-line inpf)))
|
|
(begin (assert (string? line))
|
|
(parse-string-literal line)))))
|
|
|
|
(: open-inpf (String -> Input-Port))
|
|
(define (open-inpf inpf-filename)
|
|
(if (string=? inpf-filename "-")
|
|
(current-input-port)
|
|
(open-input-file inpf-filename)))
|
|
|
|
(: open-outf (String -> Output-Port))
|
|
(define (open-outf outf-filename)
|
|
(if (string=? outf-filename "-")
|
|
(current-output-port)
|
|
(open-output-file outf-filename #:exists 'truncate)))
|
|
|
|
(: word-signbit? (Word -> Boolean))
|
|
(define (word-signbit? x)
|
|
;; True if and only if the sign bit is set.
|
|
(not (zero? (bitwise-and x #x80000000))))
|
|
|
|
(: word-add (Word Word -> Word))
|
|
(define (word-add x y)
|
|
;; Addition with overflow freely allowed.
|
|
(cast (bitwise-and (+ x y) #xFFFFFFFF) Word))
|
|
|
|
(: word-neg (Word -> Word))
|
|
(define (word-neg x)
|
|
;; The two's complement.
|
|
(word-add (cast (bitwise-xor x #xFFFFFFFF) Word) 1))
|
|
|
|
(: word-sub (Word Word -> Word))
|
|
(define (word-sub x y)
|
|
;; Subtraction with overflow freely allowed.
|
|
(word-add x (word-neg y)))
|
|
|
|
(: word-mul (Word Word -> Word))
|
|
(define (word-mul x y)
|
|
;; Signed multiplication.
|
|
(let ((x<0 (word-signbit? x))
|
|
(y<0 (word-signbit? y)))
|
|
(let ((abs-x (if x<0 (word-neg x) x))
|
|
(abs-y (if y<0 (word-neg y) y)))
|
|
(let* ((abs-xy (cast (bitwise-and (* abs-x abs-y) #xFFFFFFFF)
|
|
Word)))
|
|
(if x<0
|
|
(if y<0 abs-xy (word-neg abs-xy))
|
|
(if y<0 (word-neg abs-xy) abs-xy))))))
|
|
|
|
(: word-div (Word Word -> Word))
|
|
(define (word-div x y)
|
|
;; The quotient after signed integer division with truncation
|
|
;; towards zero.
|
|
(let ((x<0 (word-signbit? x))
|
|
(y<0 (word-signbit? y)))
|
|
(let ((abs-x (if x<0 (word-neg x) x))
|
|
(abs-y (if y<0 (word-neg y) y)))
|
|
(let* ((abs-x/y (cast (bitwise-and (quotient abs-x abs-y)
|
|
#xFFFFFFFF)
|
|
Word)))
|
|
(if x<0
|
|
(if y<0 abs-x/y (word-neg abs-x/y))
|
|
(if y<0 (word-neg abs-x/y) abs-x/y))))))
|
|
|
|
(: word-mod (Word Word -> Word))
|
|
(define (word-mod x y)
|
|
;; The remainder after signed integer division with truncation
|
|
;; towards zero.
|
|
(let ((x<0 (word-signbit? x))
|
|
(y<0 (word-signbit? y)))
|
|
(let ((abs-x (if x<0 (word-neg x) x))
|
|
(abs-y (if y<0 (word-neg y) y)))
|
|
(let* ((abs-x/y (cast (bitwise-and (remainder abs-x abs-y)
|
|
#xFFFFFFFF)
|
|
Word)))
|
|
(if x<0
|
|
(if y<0 abs-x/y (word-neg abs-x/y))
|
|
(if y<0 (word-neg abs-x/y) abs-x/y))))))
|
|
|
|
(: b2i (Boolean -> (U Zero One)))
|
|
(define (b2i b)
|
|
(if b 1 0))
|
|
|
|
(: word-lt (Word Word -> Word))
|
|
(define (word-lt x y)
|
|
;; Signed comparison: is x less than y?
|
|
(let ((x<0 (word-signbit? x))
|
|
(y<0 (word-signbit? y)))
|
|
(b2i (if x<0
|
|
(if y<0 (< x y) #t)
|
|
(if y<0 #f (< x y))))))
|
|
|
|
(: word-le (Word Word -> Word))
|
|
(define (word-le x y)
|
|
;; Signed comparison: is x less than or equal to y?
|
|
(let ((x<0 (word-signbit? x))
|
|
(y<0 (word-signbit? y)))
|
|
(b2i (if x<0
|
|
(if y<0 (<= x y) #t)
|
|
(if y<0 #f (<= x y))))))
|
|
|
|
(: word-gt (Word Word -> Word))
|
|
(define (word-gt x y)
|
|
;; Signed comparison: is x greater than y?
|
|
(let ((x<0 (word-signbit? x))
|
|
(y<0 (word-signbit? y)))
|
|
(b2i (if x<0
|
|
(if y<0 (> x y) #f)
|
|
(if y<0 #t (> x y))))))
|
|
|
|
(: word-ge (Word Word -> Word))
|
|
(define (word-ge x y)
|
|
;; Signed comparison: is x greater than or equal to y?
|
|
(let ((x<0 (word-signbit? x))
|
|
(y<0 (word-signbit? y)))
|
|
(b2i (if x<0
|
|
(if y<0 (>= x y) #f)
|
|
(if y<0 #t (>= x y))))))
|
|
|
|
(: word-eq (Word Word -> Word))
|
|
(define (word-eq x y)
|
|
;; Is x equal to y?
|
|
(b2i (= x y)))
|
|
|
|
(: word-ne (Word Word -> Word))
|
|
(define (word-ne x y)
|
|
;; Is x not equal to y?
|
|
(b2i (not (= x y))))
|
|
|
|
(: word-cmp (Word -> Word))
|
|
(define (word-cmp x)
|
|
;; The logical complement.
|
|
(b2i (zero? x)))
|
|
|
|
(: word-and (Word Word -> Word))
|
|
(define (word-and x y)
|
|
;; The logical conjunction.
|
|
(b2i (and (not (zero? x)) (not (zero? y)))))
|
|
|
|
(: word-or (Word Word -> Word))
|
|
(define (word-or x y)
|
|
;; The logical disjunction.
|
|
(b2i (or (not (zero? x)) (not (zero? y)))))
|
|
|
|
(: unop (Stack-Memory Register (Word -> Word) -> Void))
|
|
(define (unop stack sp operation)
|
|
;; Perform a unary operation on the stack.
|
|
(let ((i (unbox sp)))
|
|
(unless (<= 1 i)
|
|
(raise-user-error "stack underflow"))
|
|
(let ((x (vector-ref stack (- i 1))))
|
|
;; Note how, in contrast to Common Lisp, "operation" is not in a
|
|
;; namespace separate from that of "ordinary" values, such as
|
|
;; numbers and strings. (Which way is "better" is a matter of
|
|
;; taste, and probably depends mostly on what "functional"
|
|
;; language one learnt first. Mine was Caml Light, so I prefer
|
|
;; the Scheme way. :) )
|
|
(vector-set! stack (- i 1) (operation x)))))
|
|
|
|
(: binop (Stack-Memory Register (Word Word -> Word) -> Void))
|
|
(define (binop stack sp operation)
|
|
;; Perform a binary operation on the stack.
|
|
(let ((i (unbox sp)))
|
|
(unless (<= 2 i)
|
|
(raise-user-error "stack underflow"))
|
|
(let ((x (vector-ref stack (- i 2)))
|
|
(y (vector-ref stack (- i 1))))
|
|
(vector-set! stack (- i 2) (operation x y)))
|
|
(set-box! sp (cast (- i 1) Word))))
|
|
|
|
(: jri (Executable-Memory Register -> Void))
|
|
(define (jri code ip)
|
|
;; Jump relative immediate.
|
|
(let ((j (unbox ip)))
|
|
(unless (<= (+ j 4) executable-memory-size)
|
|
(raise-user-error "address past end of executable memory"))
|
|
;; Big-endian order.
|
|
(let* ((offset (vector-ref code (+ j 3)))
|
|
(offset (bitwise-ior
|
|
(arithmetic-shift (vector-ref code (+ j 2)) 8)
|
|
offset))
|
|
(offset (bitwise-ior
|
|
(arithmetic-shift (vector-ref code (+ j 1)) 16)
|
|
offset))
|
|
(offset (bitwise-ior
|
|
(arithmetic-shift (vector-ref code j) 24)
|
|
offset)))
|
|
(set-box! ip (word-add j (cast offset Word))))))
|
|
|
|
(: jriz (Stack-Memory Register Executable-Memory Register -> Void))
|
|
(define (jriz stack sp code ip)
|
|
;; Jump relative immediate, if zero.
|
|
(let ((i (unbox sp)))
|
|
(unless (<= 1 i)
|
|
(raise-user-error "stack underflow"))
|
|
(let ((x (vector-ref stack (- i 1))))
|
|
(set-box! sp (- i 1))
|
|
(if (zero? x)
|
|
(jri code ip)
|
|
(let ((j (unbox ip)))
|
|
(set-box! ip (cast (+ j 4) Word)))))))
|
|
|
|
(: get-immediate-value (Executable-Memory Register -> Word))
|
|
(define (get-immediate-value code ip)
|
|
(let ((j (unbox ip)))
|
|
(unless (<= (+ j 4) executable-memory-size)
|
|
(raise-user-error "address past end of executable memory"))
|
|
;; Big-endian order.
|
|
(let* ((x (vector-ref code (+ j 3)))
|
|
(x (bitwise-ior
|
|
(arithmetic-shift (vector-ref code (+ j 2)) 8)
|
|
x))
|
|
(x (bitwise-ior
|
|
(arithmetic-shift (vector-ref code (+ j 1)) 16)
|
|
x))
|
|
(x (bitwise-ior
|
|
(arithmetic-shift (vector-ref code j) 24)
|
|
x)))
|
|
(set-box! ip (cast (+ j 4) Word))
|
|
(cast x Word))))
|
|
|
|
(: pushi (Stack-Memory Register Executable-Memory Register -> Void))
|
|
(define (pushi stack sp code ip)
|
|
;; Push-immediate a value from executable memory onto the stack.
|
|
(let ((i (unbox sp)))
|
|
(unless (< i stack-memory-size)
|
|
(raise-user-error "stack overflow"))
|
|
(vector-set! stack i (get-immediate-value code ip))
|
|
(set-box! sp (cast (+ i 1) Word))))
|
|
|
|
(: fetch (Stack-Memory
|
|
Register Executable-Memory Register
|
|
Data-Memory -> Void))
|
|
(define (fetch stack sp code ip data)
|
|
;; Fetch data to the stack, using the storage location given in
|
|
;; executable memory.
|
|
(let ((i (unbox sp)))
|
|
(unless (< i stack-memory-size)
|
|
(raise-user-error "stack overflow"))
|
|
(let* ((k (get-immediate-value code ip))
|
|
(x (vector-ref data k)))
|
|
(vector-set! stack i x)
|
|
(set-box! sp (cast (+ i 1) Word)))))
|
|
|
|
(: pop-one (Stack-Memory Register -> Word))
|
|
(define (pop-one stack sp)
|
|
(let ((i (unbox sp)))
|
|
(unless (<= 1 i)
|
|
(raise-user-error "stack underflow"))
|
|
(let* ((x (vector-ref stack (- i 1))))
|
|
(set-box! sp (- i 1))
|
|
x)))
|
|
|
|
(: store (Stack-Memory
|
|
Register Executable-Memory Register
|
|
Data-Memory -> Void))
|
|
(define (store stack sp code ip data)
|
|
;; Store data from the stack, using the storage location given in
|
|
;; executable memory.
|
|
(let ((i (unbox sp)))
|
|
(unless (<= 1 i)
|
|
(raise-user-error "stack underflow"))
|
|
(let ((k (get-immediate-value code ip))
|
|
(x (pop-one stack sp)))
|
|
(vector-set! data k x))))
|
|
|
|
(: prti (Stack-Memory Register Output-Port -> Void))
|
|
(define (prti stack sp outf)
|
|
;; Print the top value of the stack, as a signed decimal value.
|
|
(let* ((n (pop-one stack sp))
|
|
(n<0 (word-signbit? n)))
|
|
(if n<0
|
|
(begin (display "-" outf)
|
|
(display (word-neg n) outf))
|
|
(display n outf))))
|
|
|
|
(: prtc (Stack-Memory Register Output-Port -> Void))
|
|
(define (prtc stack sp outf)
|
|
;; Print the top value of the stack, as a character.
|
|
(let ((c (pop-one stack sp)))
|
|
(display (integer->char c) outf)))
|
|
|
|
(: prts (Stack-Memory
|
|
Register (Immutable-Vectorof String) Output-Port -> Void))
|
|
(define (prts stack sp strings outf)
|
|
;; Print the string specified by the top of the stack.
|
|
(let* ((k (pop-one stack sp))
|
|
(s (vector-ref strings k)))
|
|
(display s outf)))
|
|
|
|
;;
|
|
;; I have written macros in the standard R6RS fashion, with a lambda
|
|
;; and syntax-case, so the examples may be widely illustrative. Racket
|
|
;; supports this style, despite (purposely) not adhering to any Scheme
|
|
;; standard.
|
|
;;
|
|
;; Some Schemes that do not provide syntax-case (CHICKEN, for
|
|
;; instance) provide alternatives that may be quite different.
|
|
;;
|
|
;; R5RS and R7RS require only syntax-rules, which cannot do what we
|
|
;; are doing here. (What we are doing is similar to using ## in a
|
|
;; modern C macro, except that the pieces are not merely raw text, and
|
|
;; they must be properly typed at every stage.)
|
|
;;
|
|
(define-syntax define-machine-binop
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
((_ op)
|
|
(let* ((op^ (syntax->datum #'op))
|
|
(machine-op (string-append "machine-" op^))
|
|
(machine-op (string->symbol machine-op))
|
|
(machine-op (datum->syntax stx machine-op))
|
|
(word-op (string-append "word-" op^))
|
|
(word-op (string->symbol word-op))
|
|
(word-op (datum->syntax stx word-op)))
|
|
#`(begin
|
|
(: #,machine-op (Machine -> Void))
|
|
(define (#,machine-op mach)
|
|
(binop (machine-stack mach)
|
|
(machine-sp mach)
|
|
#,word-op))))))))
|
|
|
|
(define-syntax define-machine-unop
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
((_ op)
|
|
(let* ((op^ (syntax->datum #'op))
|
|
(machine-op (string-append "machine-" op^))
|
|
(machine-op (string->symbol machine-op))
|
|
(machine-op (datum->syntax stx machine-op))
|
|
(word-op (string-append "word-" op^))
|
|
(word-op (string->symbol word-op))
|
|
(word-op (datum->syntax stx word-op)))
|
|
#`(begin
|
|
(: #,machine-op (Machine -> Void))
|
|
(define (#,machine-op mach)
|
|
(unop (machine-stack mach)
|
|
(machine-sp mach)
|
|
#,word-op))))))))
|
|
|
|
(define-machine-binop "add")
|
|
(define-machine-binop "sub")
|
|
(define-machine-binop "mul")
|
|
(define-machine-binop "div")
|
|
(define-machine-binop "mod")
|
|
(define-machine-binop "lt")
|
|
(define-machine-binop "gt")
|
|
(define-machine-binop "le")
|
|
(define-machine-binop "ge")
|
|
(define-machine-binop "eq")
|
|
(define-machine-binop "ne")
|
|
(define-machine-binop "and")
|
|
(define-machine-binop "or")
|
|
|
|
(define-machine-unop "neg")
|
|
|
|
(: machine-not (Machine -> Void))
|
|
(define (machine-not mach)
|
|
(unop (machine-stack mach)
|
|
(machine-sp mach)
|
|
word-cmp))
|
|
|
|
(: machine-prtc (Machine -> Void))
|
|
(define (machine-prtc mach)
|
|
(prtc (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-output mach)))
|
|
|
|
(: machine-prti (Machine -> Void))
|
|
(define (machine-prti mach)
|
|
(prti (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-output mach)))
|
|
|
|
(: machine-prts (Machine -> Void))
|
|
(define (machine-prts mach)
|
|
(prts (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-strings mach)
|
|
(machine-output mach)))
|
|
|
|
(: machine-fetch (Machine -> Void))
|
|
(define (machine-fetch mach)
|
|
(fetch (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-code mach)
|
|
(machine-ip mach)
|
|
(machine-data mach)))
|
|
|
|
(: machine-store (Machine -> Void))
|
|
(define (machine-store mach)
|
|
(store (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-code mach)
|
|
(machine-ip mach)
|
|
(machine-data mach)))
|
|
|
|
(: machine-push (Machine -> Void))
|
|
(define (machine-push mach)
|
|
(pushi (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-code mach)
|
|
(machine-ip mach)))
|
|
|
|
(: machine-jmp (Machine -> Void))
|
|
(define (machine-jmp mach)
|
|
(jri (machine-code mach)
|
|
(machine-ip mach)))
|
|
|
|
(: machine-jz (Machine -> Void))
|
|
(define (machine-jz mach)
|
|
(jriz (machine-stack mach)
|
|
(machine-sp mach)
|
|
(machine-code mach)
|
|
(machine-ip mach)))
|
|
|
|
(: get-opcode (Machine -> Byte))
|
|
(define (get-opcode mach)
|
|
(let ((code (machine-code mach))
|
|
(ip (machine-ip mach)))
|
|
(let ((j (unbox ip)))
|
|
(unless (< j executable-memory-size)
|
|
(raise-user-error "address past end of executable memory"))
|
|
(let ((opcode (vector-ref code j)))
|
|
(set-box! ip (cast (+ j 1) Word))
|
|
opcode))))
|
|
|
|
(: run-instruction (Machine Byte -> Void))
|
|
(define (run-instruction mach opcode)
|
|
(let ((op-mod-4 (bitwise-and opcode #x3))
|
|
(op-div-4 (arithmetic-shift opcode -2)))
|
|
(match op-div-4
|
|
(0 (match op-mod-4
|
|
(1 (machine-add mach))
|
|
(2 (machine-sub mach))
|
|
(3 (machine-mul mach))))
|
|
(1 (match op-mod-4
|
|
(0 (machine-div mach))
|
|
(1 (machine-mod mach))
|
|
(2 (machine-lt mach))
|
|
(3 (machine-gt mach))))
|
|
(2 (match op-mod-4
|
|
(0 (machine-le mach))
|
|
(1 (machine-ge mach))
|
|
(2 (machine-eq mach))
|
|
(3 (machine-ne mach))))
|
|
(3 (match op-mod-4
|
|
(0 (machine-and mach))
|
|
(1 (machine-or mach))
|
|
(2 (machine-neg mach))
|
|
(3 (machine-not mach))))
|
|
(4 (match op-mod-4
|
|
(0 (machine-prtc mach))
|
|
(1 (machine-prti mach))
|
|
(2 (machine-prts mach))
|
|
(3 (machine-fetch mach))))
|
|
(5 (match op-mod-4
|
|
(0 (machine-store mach))
|
|
(1 (machine-push mach))
|
|
(2 (machine-jmp mach))
|
|
(3 (machine-jz mach)))))))
|
|
|
|
(: run-vm (Machine -> Void))
|
|
(define (run-vm mach)
|
|
(let ((opcode-for-halt (cast (opcode-from-name "halt") Byte))
|
|
(opcode-for-add (cast (opcode-from-name "add") Byte))
|
|
(opcode-for-jz (cast (opcode-from-name "jz") Byte)))
|
|
(let loop ((opcode (get-opcode mach)))
|
|
(unless (= opcode opcode-for-halt)
|
|
(begin
|
|
(when (or (< opcode opcode-for-add)
|
|
(< opcode-for-jz opcode))
|
|
(raise-user-error "unsupported opcode"))
|
|
(run-instruction mach opcode)
|
|
(loop (get-opcode mach)))))))
|
|
|
|
(define (usage-error)
|
|
(display "Usage: vm [INPUTFILE [OUTPUTFILE]]" (current-error-port))
|
|
(newline (current-error-port))
|
|
(display "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
|
|
(current-error-port))
|
|
(display " standard I/O is used." (current-error-port))
|
|
(newline (current-error-port))
|
|
(exit 1))
|
|
|
|
(: get-filenames (-> (Values String String)))
|
|
(define (get-filenames)
|
|
(match (current-command-line-arguments)
|
|
((vector) (values "-" "-"))
|
|
((vector inpf-filename)
|
|
(values (cast inpf-filename String) "-"))
|
|
((vector inpf-filename outf-filename)
|
|
(values (cast inpf-filename String)
|
|
(cast outf-filename String)))
|
|
(_ (usage-error)
|
|
(values "" ""))))
|
|
|
|
(let-values (((inpf-filename outf-filename) (get-filenames)))
|
|
(let* ((inpf (open-inpf inpf-filename))
|
|
(outf (open-outf outf-filename)))
|
|
(let-values (((datasize strings-count)
|
|
(read-datasize-and-strings-count inpf)))
|
|
(let* ((strings
|
|
(vector->immutable-vector
|
|
(list->vector
|
|
(read-string-literals inpf strings-count))))
|
|
(instructions (read-instructions inpf))
|
|
|
|
(mach (make-machine strings outf)))
|
|
|
|
(unless (<= datasize data-memory-size)
|
|
(raise-user-error
|
|
"the VM's data memory size is exceeded"))
|
|
|
|
(load-executable-memory (machine-code mach) instructions)
|
|
(run-vm mach)
|
|
|
|
(unless (string=? inpf-filename "-")
|
|
(close-input-port inpf))
|
|
(unless (string=? outf-filename "-")
|
|
(close-output-port outf))
|
|
|
|
(exit 0)))))
|