implemented npc.lisp
Pascal J. Bourguignon [2013-12-26 21:32]
diff --git a/npc.lisp b/npc.lisp
new file mode 100644
index 0000000..c5c5581
--- /dev/null
+++ b/npc.lisp
@@ -0,0 +1,244 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE: npc.lisp
+;;;;LANGUAGE: Common-Lisp
+;;;;SYSTEM: Common-Lisp
+;;;;USER-INTERFACE: NONE
+;;;;DESCRIPTION
+;;;;
+;;;; Implemented a simple npc compiler targetting the npvm.
+;;;;
+;;;;AUTHORS
+;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;; 2013-12-26 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;; AGPL3
+;;;;
+;;;; Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;; This program is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU Affero General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU Affero General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Affero General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NP-COMPILER"
+ (:use "COMMON-LISP"
+ "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NPVM")
+ (:export
+ "NP-COMPILE"
+ "PROGN" "<-" "PRINT" "DUMP" "NEG" "+" "*" "-" "/"))
+
+(in-package "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NP-COMPILER")
+
+#-(and)
+'(progn
+ (<- var expr)
+
+ (* expr1 expr2)
+ (+ expr1 expr2)
+ (/ expr1 expr2)
+ (- expr1 expr2)
+
+ (print expr)
+ (neg expr)
+
+ (dump))
+
+(defun generate (program code &rest codes)
+ (assert (every (function numberp) (cons code codes)))
+ (dolist (code (cons code codes))
+ (vector-push-extend code program (length program))))
+
+(defun check-arity (n expr)
+ (unless (= n (length (rest expr)))
+ (error "~S is an operator that takes ~D argument~:*~P; ~S is invalid."
+ (first expr) n expr)))
+
+
+(defun np-generate (expr variables program)
+ (cond
+ ((numberp expr) (generate program +pushi+ expr))
+ ((symbolp expr) (generate program +pushn+ (variable-index variables expr)))
+ ((atom expr) (error "Unexpected atom ~S" expr))
+ (t (case (first expr)
+
+ ((progn)
+ (loop
+ :for expr :in (rest expr)
+ :do (np-generate expr variables program)))
+
+ ((+ * - /)
+ (check-arity 2 expr)
+ (np-generate (second expr) variables program)
+ (np-generate (third expr) variables program)
+ (generate program (case (first expr)
+ ((+) +add+)
+ ((*) +mul+)
+ ((-) +sub+)
+ ((/) +div+))))
+
+ ((<-)
+ (check-arity 2 expr)
+ (unless (symbolp (second expr))
+ (error "<- takes a variable as target, not ~S" (second expr)))
+ (np-generate (third expr) variables program)
+ (np-generate (second expr) variables program)
+ (generate program +store+))
+
+ ((print)
+ (check-arity 1 expr)
+ (np-generate (second expr) variables program)
+ (generate program +print+))
+
+ ((neg)
+ (check-arity 1 expr)
+ (np-generate (second expr) variables program)
+ (generate program +neg+))
+
+ ((dump)
+ (check-arity 0 expr)
+ (generate program +dump+))
+
+ (otherwise
+ (error "Invalid operator in ~S" expr))))))
+
+
+(defun collect-variables (expr)
+ (let ((variables '()))
+ (labels ((collect (expr)
+ (cond
+ ((symbolp expr) (push expr variables))
+ ((atom expr))
+ (t (dolist (subexpr (rest expr))
+ (collect subexpr))))))
+ (collect expr)
+ (remove-duplicates variables))))
+
+(defun variable-index (variables var)
+ (position var variables))
+
+
+(defun set-equal (a b) (and (subsetp a b) (subsetp b a)))
+(defun test/collect-variables ()
+ (assert (set-equal (collect-variables '(progn
+ (<- var (neg expr))
+ (* (+ 33 expr2) (/ 42 expr2))
+ (print (- expr1 expr2))
+ (dump)))
+ '(expr1 expr2 expr var)))
+ :success)
+(test/collect-variables)
+
+(defun np-compile (expr)
+ (let ((variables (collect-variables expr))
+ (program (make-array 100 :adjustable t :fill-pointer 0)))
+ (when (< +max-variables+ (length variables))
+ (error "~D is too many variables, memory has only ~D slots."
+ (length variables) +max-variables+))
+ (np-generate expr variables program)
+ (generate program +stop+)
+ (values program variables)))
+
+(defun np-disassemble (pgm)
+ (let ((vm (make-vm :program pgm)))
+ (loop
+ :for pc := (vm-disassemble vm 0) :then (vm-disassemble vm pc)
+ :while (< pc (length pgm)))))
+
+(np-disassemble (np-compile
+ ;; 5 5 + d !
+ ;; d d * c !
+ ;; d c * m !
+ ;; d =
+ ;; c =
+ ;; m =
+ ;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
+ '(progn
+ (<- d (+ 5 5))
+ (<- c (* d d))
+ (<- m (* d c))
+ (print d)
+ (print c)
+ (print m)
+ (<- a (+ 4 (* (+ 6 (* (+ 9 (* (+ 1 (* 0 d)) d)) d)) d)))
+ (print a))))
+
+ ;; 0: (pushi 5)
+ ;; 2: (pushi 5)
+ ;; 4: (add)
+ ;; 5: (pushn d)
+ ;; 7: (store)
+ ;; 8: (pushn d)
+ ;; 10: (pushn d)
+ ;; 12: (mul)
+ ;; 13: (pushn c)
+ ;; 15: (store)
+ ;; 16: (pushn d)
+ ;; 18: (pushn c)
+ ;; 20: (mul)
+ ;; 21: (pushn b)
+ ;; 23: (store)
+ ;; 24: (pushn d)
+ ;; 26: (print)
+ ;; 27: (pushn c)
+ ;; 29: (print)
+ ;; 30: (pushn b)
+ ;; 32: (print)
+ ;; 33: (pushi 4)
+ ;; 35: (pushi 6)
+ ;; 37: (pushi 9)
+ ;; 39: (pushi 1)
+ ;; 41: (pushi 0)
+ ;; 43: (pushn d)
+ ;; 45: (mul)
+ ;; 46: (add)
+ ;; 47: (pushn d)
+ ;; 49: (mul)
+ ;; 50: (add)
+ ;; 51: (pushn d)
+ ;; 53: (mul)
+ ;; 54: (add)
+ ;; 55: (pushn d)
+ ;; 57: (mul)
+ ;; 58: (add)
+ ;; 59: (pushn a)
+ ;; 61: (store)
+ ;; 62: (pushn a)
+ ;; 64: (print)
+ ;; 65: (stop)
+
+
+(vm-run (make-vm :program (np-compile
+ ;; 5 5 + d !
+ ;; d d * c !
+ ;; d c * m !
+ ;; d =
+ ;; c =
+ ;; m =
+ ;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
+ '(progn
+ (<- d (+ 5 5))
+ (<- c (* d d))
+ (<- m (* d c))
+ (print d)
+ (print c)
+ (print m)
+ (<- a (+ 4 (* (+ 6 (* (+ 9 (* (+ 1 (* 0 d)) d)) d)) d)))
+ (print a)))))
+;; prints:
+;; 10
+;; 100
+;; 1000
+;; 1964
+;; --> 66
diff --git a/npvm.lisp b/npvm.lisp
index 3d47a03..4b8de59 100644
--- a/npvm.lisp
+++ b/npvm.lisp
@@ -1,180 +1,247 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE: npvm.lisp
+;;;;LANGUAGE: Common-Lisp
+;;;;SYSTEM: Common-Lisp
+;;;;USER-INTERFACE: NONE
+;;;;DESCRIPTION
+;;;;
+;;;; XXX
+;;;;
+;;;;AUTHORS
+;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;; 2013-12-25 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;; AGPL3
+;;;;
+;;;; Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;; This program is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU Affero General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU Affero General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Affero General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NPVM"
+ (:use "COMMON-LISP")
+ (:export
+ "+MAX-VARIABLES+"
+
+ "+PUSHI+" "+PUSHN+" "+STORE+" "+NEG+" "+ADD+" "+MUL+" "+SUB+"
+ "+DIV+" "+PRINT+" "+DUMP+" "+STOP+"
+
+ "VM" "MAKE-VM" "VM-P" "COPY-VM" "VM-STACK" "VM-MEMORY" "VM-PROGRAM"
+ "VM-SP" "VM-PC" "VM-RESET" "VM-DUMP" "VM-RUN" "VM-DISASSEMBLE"))
+
+(in-package "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NPVM")
+
+(defconstant +MAX-VARIABLES+ 26)
-(defvar *stack* (make-array 100 :fill-pointer 0))
-(defvar *memory* (make-array 26 :initial-element 0))
+(defconstant +pushi+ 0)
+(defconstant +pushn+ 1)
+(defconstant +store+ 2)
+(defconstant +neg+ 3)
+(defconstant +add+ 4)
+(defconstant +mul+ 5)
+(defconstant +sub+ 6)
+(defconstant +div+ 7)
+(defconstant +print+ 8)
+(defconstant +dump+ 9)
+(defconstant +stop+ 10)
+
+(defvar *codops* #((pushi i)
+ (pushn n)
+ (store)
+ (neg)
+ (add)
+ (mul)
+ (sub)
+ (div)
+ (print)
+ (dump)
+ (stop)))
+
+(defstruct vm "Implementation of a simple Stack Virtual Machine"
+ (stack (make-array 100))
+ (memory (make-array +MAX-VARIABLES+ :initial-element 0))
+ (program (make-array 1 :initial-element +stop+))
+ (sp 1)
+ (pc 0))
-(defun reset ()
- (setf *stack* (make-array 100 :fill-pointer 0)
- *memory* (make-array 26 :initial-element 0))
+
+(defun vm-reset (vm)
+ (setf (vm-stack vm) (make-array 100 :fill-pointer 0)
+ (vm-memory vm) (make-array 26 :initial-element 0)
+ (vm-pc vm) 0
+ (vm-sp vm) 0)
(values))
-(defvar *names* "abcdefghijklmnopqrstuvwxyz")
+
+(defvar *names* "abcdefghijklmnopqrstuvwxyz")
(defun index-to-name (i)
(aref *names* i))
(defun index-from-name (name)
(position name *names*))
-(defun vm-sp ()
- (fill-pointer *stack*))
-
-(defun test/vm-push ()
- (let ((old-sp (vm-sp)))
- (vm-push 42)
- (assert (= (1+ old-sp) (vm-sp))))
- :success)
-
-(test/vm-push) ; --> :success
-
-
-(defun dump ()
+(defun vm-dump (vm)
(loop
- :for i :below (fill-pointer *stack*)
+ :for i :below (vm-sp vm)
:initially (format t "--------------------~%")
- :do (format t "[~3D]: ~10D~%" i (aref *stack* i))
+ :do (format t "[~3D]: ~10D~%" i (aref (vm-stack vm) i))
:finally (format t "--------------------~%"))
(loop
- :for i :below (length *memory*)
- :do (format t "[~3D]: ~10D~%" (index-to-name i) (aref *memory* i))
+ :for i :below (length (vm-memory vm))
+ :do (format t "[~3D]: ~10D~%" (index-to-name i) (aref (vm-memory vm) i))
:finally (format t "--------------------~%")))
(defun namep (x) (consp x))
(defun wrap-name (x) (cons 'name x))
(defun unwrap-name (x) (cdr x))
-(defun vm-push (n)
- (if (< (fill-pointer *stack*) (array-dimension *stack* 0))
- (vector-push n *stack*)
- (error "Stack is full")))
-
-(defun vm-pushv (n)
- (if (< (fill-pointer *stack*) (array-dimension *stack* 0))
- (vector-push (wrap-name n) *stack*)
- (error "Stack is full")))
-
-(defun vm-pop ()
- (if (plusp (fill-pointer *stack*))
- (let ((value (vector-pop *stack*)))
- (if (namep value)
- (vm-retrieve value)
- value))
- (error "Stack is empty")))
-
-(defun vm-popv ()
- (if (plusp (fill-pointer *stack*))
- (vector-pop *stack*)
- (error "Stack is empty")))
-
-(defun vm-store (d x)
- (if (< -1 (unwrap-name d) (length *memory*))
- (setf (aref *memory* (unwrap-name d)) x)
+(defun vm-push (vm n)
+ (if (< (vm-sp vm) (array-dimension (vm-stack vm) 0))
+ (setf (aref (vm-stack vm) (vm-sp vm)) n
+ (vm-sp vm) (1+ (vm-sp vm)))
+ (error "Stack is full - vm-push")))
+
+(defun vm-pushv (vm n)
+ (if (< (vm-sp vm) (array-dimension (vm-stack vm) 0))
+ (setf (aref (vm-stack vm) (vm-sp vm)) (wrap-name n)
+ (vm-sp vm) (1+ (vm-sp vm)))
+ (error "Stack is full - vm-pushv")))
+
+(defun vm-pop (vm )
+ (if (plusp (vm-sp vm))
+ (progn
+ (decf (vm-sp vm))
+ (let ((value (aref (vm-stack vm) (vm-sp vm))))
+ (if (namep value)
+ (vm-retrieve vm value)
+ value)))
+ (error "Stack is empty - vm-pop")))
+
+(defun vm-popv (vm)
+ (if (plusp (vm-sp vm))
+ (progn
+ (decf (vm-sp vm))
+ (aref (vm-stack vm) (vm-sp vm)))
+ (error "Stack is empty - vm-popv")))
+
+(defun vm-store (vm d x)
+ (if (< -1 (unwrap-name d) (length (vm-memory vm)))
+ (setf (aref (vm-memory vm) (unwrap-name d)) x)
(error "Invalid memory address ~D" d)))
-(defun vm-retrieve (d)
- (if (< -1 (unwrap-name d) (length *memory*))
- (aref *memory* (unwrap-name d))
+(defun vm-retrieve (vm d)
+ (if (< -1 (unwrap-name d) (length (vm-memory vm)))
+ (aref (vm-memory vm) (unwrap-name d))
(error "Invalid memory address ~D" d)))
-
-(defconstant +pushi+ 0)
-(defconstant +pushn+ 1)
-(defconstant +store+ 2)
-(defconstant +neg+ 3)
-(defconstant +add+ 4)
-(defconstant +mul+ 5)
-(defconstant +sub+ 6)
-(defconstant +div+ 7)
-(defconstant +print+ 8)
-(defconstant +dump+ 9)
-(defconstant +stop+ 10)
-
-(defvar *codops* #((pushi i)
- (pushn n)
- (store)
- (neg)
- (add)
- (mul)
- (sub)
- (div)
- (print)
- (dump)
- (stop)))
-
-(defun vm-disassemble (pgm pc)
+(defun vm-disassemble (vm &optional (pc 0))
(format t "~3D: " pc)
- (let ((code (aref pgm (prog1 pc (incf pc)))))
- (format t "~S~%"
- (if (< -1 code (length *codops*))
- (let ((discode (aref *codops* code)))
- (if (< 1 (length discode))
- (list (first discode)
- (ecase (second discode)
- ((i) (aref pgm (prog1 pc (incf pc))))
- ((n) (intern (string-upcase
- (index-to-name
- (aref pgm (prog1 pc (incf pc)))))))))
- discode))
- `(error ,code)))
- pc))
-
-
-(defun vm-run (pgm &key (trace nil) (reset t) (pc 0))
- (when reset (reset))
- (when trace
- (let ((*print-pretty* t)
- (*print-right-margin* 72))
- (format t "~A~%PC: ~3D~%" pgm pc))
- (dump))
- (let ((pc pc))
+ (macrolet ((next-instruction ()
+ `(aref (vm-program vm) (prog1 pc (incf pc)))))
+ (let ((code (next-instruction)))
+ (format t "~(~A~)~%"
+ (if (< -1 code (length *codops*))
+ (let ((discode (aref *codops* code)))
+ (if (< 1 (length discode))
+ (list (first discode)
+ (ecase (second discode)
+ ((i) (next-instruction))
+ ((n) (intern (string-upcase
+ (index-to-name
+ (next-instruction)))))))
+ discode))
+ `(error ,code)))
+ pc)))
+
+
+(defun vm-run (vm &key (trace nil) (reset t) (pc (vm-pc vm)))
+ (when reset
+ (vm-reset vm))
+ (setf (vm-pc vm) pc)
+ (with-accessors ((program vm-program)
+ (pc vm-pc)) vm
+ (when trace
+ (let ((*print-pretty* t)
+ (*print-right-margin* 72))
+ (format t "~A~%PC: ~3D~%" program pc))
+ (vm-dump vm))
(handler-case
(loop
- (when trace (vm-disassemble pgm pc))
- (let ((code (aref pgm (prog1 pc (incf pc)))))
- (case code
- (#.+pushi+ (vm-push (aref pgm (prog1 pc (incf pc)))))
- (#.+pushn+ (vm-pushv (aref pgm (prog1 pc (incf pc)))))
- (#.+store+ (vm-store (vm-popv) (vm-pop)))
- (#.+neg+ (vm-push (- (vm-pop))))
- (#.+add+ (vm-push (+ (vm-pop) (vm-pop))))
- (#.+mul+ (vm-push (* (vm-pop) (vm-pop))))
- (#.+sub+ (let ((b (vm-pop))
- (a (vm-pop)))
- (vm-push (- a b))))
- (#.+div+ (let ((b (vm-pop))
- (a (vm-pop)))
- (when (zerop b)
- (error 'division-by-zero))
- (vm-push (/ a b))))
- (#.+print+ (format t "~D~%" (vm-pop)))
- (#.+dump+ (dump))
- (#.+stop+ (return-from vm-run pc)))))
+ (when trace (vm-disassemble program pc))
+ (macrolet ((next-instruction ()
+ `(aref program (prog1 pc (incf pc)))))
+ (let ((code (next-instruction)))
+ (case code
+ (#.+pushi+ (vm-push vm (next-instruction)))
+ (#.+pushn+ (vm-pushv vm (next-instruction)))
+ (#.+store+ (vm-store vm (vm-popv vm) (vm-pop vm)))
+ (#.+neg+ (vm-push vm (- (vm-pop vm))))
+ (#.+add+ (vm-push vm (+ (vm-pop vm) (vm-pop vm))))
+ (#.+mul+ (vm-push vm (* (vm-pop vm) (vm-pop vm))))
+ (#.+sub+ (let ((b (vm-pop vm))
+ (a (vm-pop vm)))
+ (vm-push vm (- a b))))
+ (#.+div+ (let ((b (vm-pop vm))
+ (a (vm-pop vm)))
+ (when (zerop b)
+ (error 'division-by-zero))
+ (vm-push vm (/ a b))))
+ (#.+print+ (format t "~D~%" (vm-pop vm)))
+ (#.+dump+ (vm-dump vm))
+ (#.+stop+ (return-from vm-run pc))))))
(error (err)
(format *error-output* "PC = ~D~%~A~%" pc err)))))
-;; 5 5 + d !
-;; d d * c !
-;; d c * m !
-;; d =
-;; c =
-;; m =
-;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
-
-(vm-run (vector
- +pushi+ 5 +pushi+ 5 +add+ +pushn+ 3 +store+ ; +dump+
- +pushn+ 3 +pushn+ 3 +mul+ +pushn+ 2 +store+ ; +dump+
- +pushn+ 3 +pushn+ 2 +mul+ +pushn+ 12 +store+ ; +dump+
- +pushn+ 3 +print+
- +pushn+ 2 +print+
- +pushn+ 12 +print+
- +pushi+ 4 +pushi+ 6 +pushi+ 9 +pushi+ 1 +pushi+ 0
- +pushn+ 3 +mul+ +add+
- +pushn+ 3 +mul+ +add+
- +pushn+ 3 +mul+ +add+
- +pushn+ 3 +mul+ +add+
- +pushn+ 0 +store+
- +pushn+ 0 +print+
- +stop+)
+
+
+(defun test/vm-push ()
+ (let* ((vm (make-vm))
+ (old-sp (vm-sp vm)))
+ (vm-push vm 42)
+ (assert (= (1+ old-sp) (vm-sp vm))))
+ :success)
+
+(test/vm-push)
+
+
+(vm-run (make-vm :program (vector
+ ;; 5 5 + d !
+ ;; d d * c !
+ ;; d c * m !
+ ;; d =
+ ;; c =
+ ;; m =
+ ;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
+ +pushi+ 5 +pushi+ 5 +add+ +pushn+ 3 +store+ ; +dump+
+ +pushn+ 3 +pushn+ 3 +mul+ +pushn+ 2 +store+ ; +dump+
+ +pushn+ 3 +pushn+ 2 +mul+ +pushn+ 12 +store+ ; +dump+
+ +pushn+ 3 +print+
+ +pushn+ 2 +print+
+ +pushn+ 12 +print+
+ +pushi+ 4 +pushi+ 6 +pushi+ 9 +pushi+ 1 +pushi+ 0
+ +pushn+ 3 +mul+ +add+
+ +pushn+ 3 +mul+ +add+
+ +pushn+ 3 +mul+ +add+
+ +pushn+ 3 +mul+ +add+
+ +pushn+ 0 +store+
+ +pushn+ 0 +print+
+ +stop+))
:trace nil)
;; prints: