Compiler/virtual machine interpreter: Difference between revisions

=={{header|Racket}}==

{{trans|Common Lisp}}

This example is for ''Typed'' Racket and is practically a word for word translation of the Common Lisp. This close similarity was done on purpose, to ease comparison of the two languages.

<lang 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)))))</lang>